;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; mime.cl --- MIME handling code
;;;; 
;;;; Checkout Tag: $Name$
;;;; $Id$

(in-package :CLASH)

;;;; %File Description:
;;;; 
;;;; This implements those parts of MIME that are necessary for
;;;; correct operation of HTTP processing.  Those parts that are
;;;; implemented try to conform to RFC2045, RFC2046, RFC2047 (MIME
;;;; parts 1 to 3) and especially RFC2388 (multipart/form-data).
;;;; 

(define-condition mime-syntax-error (clash-syntax-error)
  ())

(defconstant +maximum-safe-mime-token-length+ 80
  "This defines the limit we impose on MIME tokens acceptable to
`get-mime-symbol', in order to avoid interning huge stuff into the
keyword package, and thereby leaking non-negligible amounts of
memory.")

(defun get-mime-symbol (string &optional (start 0) (end (length string)))
  (when (null end) (setq end (length string)))
  (when (> (- end start) +maximum-safe-mime-token-length+)
    (error 'clash-error :code +http-code-bad-request+))
  (intern (nstring-upcase (subseq string start end))
	  (symbol-package :initarg)))

(defun render-mime-symbol (symbol stream)
  (check-type symbol keyword)
  (write-string (string-downcase (symbol-name symbol)) stream))

(defconstant +mime-type-separator+ #\/)
(defconstant +mime-parameter-separator+ #\;)
(defconstant +mime-value-separator+ #\=)
(defconstant +mime-quote-delimiter+ #\")
(defconstant +mime-quote-character+ #\\)
(defconstant +mime-specials-bag+ "()<>@,;:\\\"/[]?=")

(defun dequote-mime-string (string &optional (start 0) (end (length string)))
  (when (null end) (setq end (length string)))
  (with-output-to-string (stream)
    (do ((pos start (1+ pos)))
	((>= pos end))
      (if (char= (char string pos) +mime-quote-character+)
	  (write-char (char string (incf pos)) stream)
	  (write-char (char string pos) stream)))))

(defun parse-mime-type-string
    (string &optional (start 0) (end (length string)))
  (with-lws-trimmed-bounds (string start end)
    (let* ((type-end (or (position +mime-type-separator+ string
				   :start start :end end)
			 (skip-forward-to-lws string start end)))
	   (subtype-start (skip-forward-lws string (1+ type-end) end))
	   (subtype-end (skip-forward-to-lws string subtype-start end)))
      (values (with-lws-trimmed-bounds (string start type-end)
		(get-mime-symbol string start type-end))
	      (if (= subtype-start subtype-end)
		  nil
		  (with-lws-trimmed-bounds (string subtype-start subtype-end)
		    (get-mime-symbol string subtype-start subtype-end)))))))

(defun render-mime-type-string (type subtype stream)
  (write-string (string-downcase (symbol-name type)) stream)
  (write-char +mime-type-separator+ stream)
  (write-string (string-downcase (symbol-name subtype)) stream))

(defun parse-mime-parameters (string &optional (start 0) (end (length string)))
  (with-lws-trimmed-bounds (string start end)
    (when (= start end)
      (return-from parse-mime-parameters nil))
    (do* ((parameters nil)
	  (start start))
	 ((>= start end)
	  (return (nreverse parameters)))
      (when (char/= (char string start) +mime-parameter-separator+)
	(error 'mime-syntax-error :fragment string
	       :reason
	       "Invalid token while parsing MIME content-type parameters"))
      (setq start (skip-forward-lws string (1+ start) end))
      (do ((pos start (1+ pos)))
	  ((or (>= pos end)
	       (char= (char string pos) +mime-parameter-separator+))
	   (error 'mime-syntax-error
		  :fragment string
		  :reason "Invalid end of MIME content-type parameter"))
	(let ((char (char string pos)))
	  (when (or (char-lws-p char)
		    (char= char +mime-value-separator+))
	    (push (get-mime-symbol string start pos) parameters)
	    (setq start (skip-forward-lws string pos end))
	    (when (or (>= start end)
		      (char/= (char string start) +mime-value-separator+))
	      (error 'mime-syntax-error :fragment string
		     :reason "Invalid token in MIME content-type parameter"))
	    (setq start (skip-forward-lws string (1+ start) end))
	    (when (>= start end)
	      (error 'mime-syntax-error :fragment string
		     :reason "Missing value in MIME content-type paramter"))
	    (return nil))))
      ;; Parse Value
      (cond
	((char= (char string start) +mime-quote-delimiter+)
	 (incf start)
	 (do ((pos start (1+ pos)))
	     ((>= pos end)
	      (error 'mime-syntax-error :fragment string
		     :reason
		     "Premature end of quoted string in MIME parameter value"))
	   (when (and (char= (char string pos) +mime-quote-delimiter+)
		      (not (char= (char string (1- pos))
				  +mime-quote-character+)))
	     (push (dequote-mime-string string start  pos) parameters)
	     (setq start (skip-forward-lws string (1+ pos) end))
	     (return nil))))
	(t
	 (do ((pos start (1+ pos)))
	     ((or (>= pos end)
		  (let ((char (char string pos)))
		    (or (char= char +mime-parameter-separator+)
			(char-lws-p char))))
	      (push (subseq string start pos) parameters)
	      (setq start (skip-forward-lws string pos end)))))))))

(defun render-mime-parameters (parameters stream)
  (loop for (key value) on parameters by #'cddr
	do
	(write-char +mime-parameter-separator+ stream)
	(write-char #\Space stream)
	(write-string (string-downcase (symbol-name key)) stream)
	(write-char +mime-value-separator+ stream)
	(write-char +mime-quote-delimiter+ stream)
	(loop for char across value
	      do
	      (when (find char +mime-specials-bag+)
		(write-char +mime-quote-character+ stream))
	      (write-char char stream))
	(write-char +mime-quote-delimiter+ stream)))

(defun parse-content-type-string (string)
  (let ((parameter-start (position +mime-parameter-separator+ string)))
    (multiple-value-bind (type subtype)
	(parse-mime-type-string string 0 parameter-start)
      (list* type subtype
	     (when parameter-start
	       (parse-mime-parameters string parameter-start))))))

(defun render-content-type (content-type stream)
  (destructuring-bind (type subtype . parameters) content-type
    (render-mime-type-string type subtype stream)
    (render-mime-parameters parameters stream)))

(defun parse-content-disposition-string (string)
  (let ((parameter-start (position +mime-parameter-separator+ string))
	(start 0))
    (list*
     (with-lws-trimmed-bounds (string start parameter-start)
       (get-mime-symbol string start parameter-start))
     (when parameter-start
       (parse-mime-parameters string parameter-start)))))

(defun render-content-disposition (content-disposition stream)
  (destructuring-bind (type . parameters) content-disposition
    (render-mime-symbol type stream)
    (render-mime-parameters parameters stream)))

(defun parse-mime-headers (stream)
  (parse-http-headers stream))

;; Accessors

(defun mime-type-parameter (mime-type parameter)
  (getf (cddr mime-type) parameter))

(defun (setf mime-type-parameter) (new-value mime-type parameter)
  (setf (getf (cddr mime-type) parameter) new-value))

(defun mime-disposition-parameter (disposition parameter)
  (getf (cdr disposition) parameter))

(defun (setf mime-disposition-parameter) (new-value disposition parameter)
  (setf (getf (cdr disposition) parameter) new-value))

;; Multipart parsing

(defun multipart-skip-to-boundary (stream boundary)
  (do ((state :start-of-line)
       (char (read-char stream) (read-char stream)))
      (nil)
    (case state
      (:in-line
       (case char
	 (#\Return
	  (setq state :got-cr))
	 ;; Technically, this is illegal, but most implementations do
	 ;; recognize this, and so do we...
	 (#\Newline
	  (setq state :start-of-line))))
      (:got-cr
       (if (char= char #\Newline)
	   (setq state :start-of-line)
	   (progn
	     (unread-char char stream)
	     (setq state :in-line))))
      (:start-of-line
       (block test
	 (flet ((break-off ()
		  (unread-char char stream)
		  (setq state :in-line)
		  (return-from test nil))
		(next-char () (setq char (read-char stream))))
	   (when (char/= char #\-)
	     (break-off))
	   (when (char/= (next-char) #\-)
	     (break-off))
	   (dotimes (i (length boundary))
	     (when (char/= (next-char) (char boundary i))
	       (break-off))))
	 ;; We've got a boundary, now test for last-p and skip lws/crlf
	 (return
	   (let ((last-p nil)
		 (char (read-char stream)))
	     (when (char= char #\-)
	       (setq char (read-char stream))
	       (when (char= char #\-)
		 (setq last-p t char (read-char stream))))
	     (loop
		 (when (char= char #\Newline)
		   (return last-p))
		 (when (char= char #\Return)
		   (setq char (read-char stream)))))))))))

(defun multipart-copy-to-boundary (out stream boundary)
  (do ((state :start-of-line)
       (char (read-char stream) (read-char stream)))
      (nil)
    (case state
      (:in-line
       (case char
	 (#\Return
	  (setq state :got-cr))
	 ;; Technically, this is illegal, but most implementations do
	 ;; recognize this, and so do we...
	 (#\Newline
	  (setq state :start-of-line-lf))
	 (t
	  (write-char char out))))
      (:got-cr
       (if (char= char #\Newline)
	   (setq state :start-of-line-crlf)
	   (progn
	     (write-char #\Return out)
	     (unread-char char stream)
	     (setq state :in-line))))
      ((:start-of-line :start-of-line-lf :start-of-line-crlf)
       (block test
	 (flet ((break-off (dash-count boundary-index)
		  (when (eq state :start-of-line-crlf)
		    (write-char #\Return out))
		  (unless (eq state :start-of-line)
		    (write-char #\Newline out))
		  (dotimes (i dash-count) (write-char #\- out))
		  (write-sequence boundary out :end boundary-index)
		  (unread-char char stream)
		  (setq state :in-line)
		  (return-from test nil))
		(next-char () (setq char (read-char stream))))
	   (when (char/= char #\-)
	     (break-off 0 0))
	   (when (char/= (next-char) #\-)
	     (break-off 1 0))
	   (dotimes (i (length boundary))
	     (when (char/= (next-char) (char boundary i))
	       (break-off 2 i)))
	   ;; We've got a boundary, now test for last-p and skip lws/crlf
	   (return
	     (let ((last-p nil)
		   (char (read-char stream)))
	       (when (char= char #\-)
		 (setq char (read-char stream))
		 (when (char= char #\-)
		   (setq last-p t char (read-char stream))))
	       (loop
		   (when (char= char #\Newline)
		     (return last-p))
		   (when (char= char #\Return)
		     (setq char (read-char stream))))))))))))