;;; x310 --- test ‘(www mime-headers)’ and ‘(www mime-multipart)’

;; Copyright (C) 2013 Thien-Thi Nguyen
;;
;; This file is part of Guile-WWW.
;;
;; Guile-WWW is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; Guile-WWW is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Guile-WWW.  If not, see <https://www.gnu.org/licenses/>.

(use-modules
 ((srfi srfi-11) #:select (let-values))
 ((ice-9 rdelim) #:select (read-line))
 (ice-9 pretty-print)
 ((www mime-headers) #:select (parse-type
                               typed?
                               p-ref))
 ((www mime-multipart) #:select (parse-multipart)))

(cond-expand (guile-2 (use-modules (ice-9 binary-ports)))
             (else (use-modules (www binary-ports))))

(use-dot-d-files!)

(define-macro (with-input-port-from-dot-d filename . body)
  `(call-with-input-file (dot-d/ ,filename)
     (lambda (port)
       ,@body)))

(define (check rv msg . args)
  (or rv (begin (apply fse (string-append "sorry: " msg "~%") args)
                (exit #f))))

(define TYPE (with-input-port-from-dot-d "type"
               (parse-type (read-line port))))

(check (pair? TYPE)
       "TYPE not a pair: ~S" TYPE)
(check (equal? '(multipart . form-data) (car TYPE))
       "TYPE not multipart/form-data: ~S" (car TYPE))
(check (p-ref TYPE 'boundary)
       "no boundary in params: ~S" (cdr TYPE))

(define (check-upload move filename)
  (let ((known (dot-d/ filename))
        (fresh (string-append "x310-" filename ".fresh")))
    (call-with-output-file fresh move)
    (check (zero? (system (simple-format #f "cmp ~A ~A" known fresh)))
           "file contents mismatch:~% ~A~% ~A" known fresh)
    (vfso "file: ~A OK!~%" filename)
    (delete-file fresh)))

;; Maybe someday we will slog backwards to Guile 1.4.x,
;; which DOES have ‘(srfi srfi-4) u8vector->list’ after all...
(define uv->list u8vector->list)

(define (extract move)
  (let* ((uv (move #t))
         (ls (uv->list uv)))
    (vfso "uvec: ~S~%" uv)
    (vfso "text: ~A~%" (call-with-output-string
                        (lambda (port)
                          (put-bytevector port uv))))
    ls))

(define EXPECTED-FORM-DATA
  '((one
     ;; od -A n -j 1109 -N 38 -t u1 x310.d/body
     33 33 32 226 152 161 32 71 117 105 108 101 32 226 136 152 32 87 111
     114 108 100 45 87 105 100 101 45 87 101 98 32 226 136 158 32 33 33)
    (two
     ;; od -A n -j 1267 -N 3 -t u1 x310.d/body
     116 119 111)))

(define (check-form-input move headers)

  (define (get name)
    (let ((val (assq-ref headers name)))
      (check val "missing ~A!" name)
      val))

  (and verbose? (pretty-print headers))
  (let ((type (get 'Content-Type))
        (disp (get 'Content-Disposition)))
    (cond ((p-ref disp 'filename)
           => (lambda (filename)
                (check-upload move filename)))
          ((typed? type 'text 'plain)
           (let* ((who (string->symbol (p-ref disp 'name)))
                  (got (extract move)))
             (check (equal? got (assq-ref EXPECTED-FORM-DATA who))
                    "bad ‘~A’ data: ~S"
                    who got)))))
  (vfso "~%"))

(define (do-it!)
  (let ((body (with-input-port-from-dot-d "body"
                (parse-multipart TYPE port (stat:size (stat port))))))
    (for-each check-form-input
              (map car body)
              (map cdr body))))

(do-it!)

(let ((locale (call-with-input-file "testing-locale" read-line))
      (now #f))
  (check (string? locale) "bad locale: ~S" locale)
  (set! now (setlocale LC_ALL locale))
  (check (string? now) "setlocale ~S failed" locale)
  (vfso "locale: was unset, now ~S~%~%" now))

(do-it!)

(exit #t)

;;; Local variables:
;;; eval: (put 'with-input-port-from-dot-d 'scheme-indent-function 1)
;;; End:
;;; x310 ends here
