;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; multipart-form-data
;;; Reads & decodes HTTP multipart/form-data requests.
;;;
;;;  Copyright (C) 2014, Andy Bennett
;;;  All rights reserved.
;;;
;;;  Redistribution and use in source and binary forms, with or without
;;;  modification, are permitted provided that the following conditions are met:
;;;
;;;  Redistributions of source code must retain the above copyright notice, this
;;;  list of conditions and the following disclaimer.
;;;  Redistributions in binary form must reproduce the above copyright notice,
;;;  this list of conditions and the following disclaimer in the documentation
;;;  and/or other materials provided with the distribution.
;;;  Neither the name of the author nor the names of its contributors may be
;;;  used to endorse or promote products derived from this software without
;;;  specific prior written permission.
;;;
;;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;;  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;;  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
;;;  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;;  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;;  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;;  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;;  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;;  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;  POSSIBILITY OF SUCH DAMAGE.
;;;
;;; Andy Bennett <andyjpb@knodium.com>, 2014/09/28
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module multipart-form-data
	(http-multipart-request-data-limit ; TODO : implement enforcement
	  read-multipart-form-data
	  multipart-form-data-decode
	  multipart-file?
	  multipart-file-filename
	  multipart-file-headers
	  multipart-file-port)

(import chicken scheme)
(use data-structures srfi-14 ports extras)
(use intarweb comparse records)


; PARSERS

(define CR     (in (ucs-range->char-set 13 14))) ; 13
(define LF     (in (ucs-range->char-set 10 11))) ; 10
(define CRLF   (sequence CR LF))

(define DASHDASH (char-seq "--"))


; fIorz's separated-by parser :
(define (separated-by sep-parser field-parser)
  (sequence* ((head field-parser)
	      (tail (zero-or-more
		      (preceded-by
			sep-parser
			field-parser))))

	     (result (cons head tail))))


(define (parts boundary)
  (let* ((boundary (char-seq boundary)))

    (sequence* ((_ (zero-or-more ; preamble
		     (none-of* (sequence DASHDASH boundary CRLF)
			       (zero-or-more item))))

		(parts (one-or-more ; 1*encapsulation
			 (preceded-by
			   (sequence (maybe CRLF) DASHDASH boundary CRLF)
			   (zero-or-more
			     (none-of* (sequence CRLF DASHDASH boundary)
				       item)))))

		(_ (sequence CRLF DASHDASH boundary DASHDASH)) ; close-delimiter
		(_ (any-of item))) ; epilogue

	       (result parts))))


; DATA STRUCTURES
(define multipart-file-fields
  '(filename
     headers
     port))

(define multipart-file-rtd
  (make-record-type 'MULTIPART-FILE multipart-file-fields))

(define-record-printer (MULTIPART-FILE e out)
		       (fprintf out "#<MULTIPART-FILE: file-name:~S>"
				(multipart-file-filename e)))

(define make-multipart-file
  (record-constructor multipart-file-rtd multipart-file-fields))



; API

; The below can be #f if you want no limit (not recommended!)
(define http-multipart-request-data-limit (make-parameter #f))


(define multipart-file?
  (record-predicate multipart-file-rtd))

(define multipart-file-filename
  (record-accessor multipart-file-rtd 'filename))

(define multipart-file-headers
  (record-accessor multipart-file-rtd 'headers))

(define multipart-file-port
  (record-accessor multipart-file-rtd 'port))


(define (read-multipart-form-data
	  request
	  #!optional
	  (max-length (http-multipart-request-data-limit)))

  (let* ((p            (request-port request))
	 (headers      (request-headers request))
	 (len          (header-value 'content-length headers))
	 (content-type (header-contents 'content-type headers))
	 (_            (assert (= 1 (length content-type))))
	 (content-type (car content-type))
	 (value        (get-value content-type))
	 (_            (assert (eqv? 'multipart/form-data value)))
	 (params       (get-params content-type))
	 (_            (assert (= 1 (length params))))
	 (boundary     (alist-ref 'boundary params))
	 (limit        (if (and len max-length)
			 (min len max-length)
			 (or max-length len)))
	 (data         (read-string limit p)))

    (multipart-form-data-decode data boundary len)))


(define (multipart-form-data-decode str-port-or-seq boundary #!optional limit)
  (let ((parts (map list->string
		    (parse (parts boundary) str-port-or-seq))))
    (map
      (lambda (part)
	(with-input-from-string part
	  (lambda ()
	    (let* ((headers (read-headers (current-input-port)))
		   (content-disposition (header-contents 'content-disposition headers))
		   (_ (assert (= 1 (length content-disposition))))
		   (content-disposition (car content-disposition))
		   (assert (eqv? 'form-data (get-value content-disposition)))
		   (params (get-params content-disposition))
		   (name (alist-ref 'name params))
		   (filename (alist-ref 'filename params)))
	      (cons (string->symbol name)
		    (if filename
		      (make-multipart-file filename
					   headers
					   (current-input-port))
		      (read-string #f (current-input-port))))))))
      parts)))

)