Pierre R. Mai
5c57e50d07
requests and entities are now parsed. Furthermore the whole request-entity handling has been changed to allow lazy parsing, parsed entity headers, and flexible choice of entities. This is all to support the handling of MIME multipart entities, especially multipart/form-data. The current revision is a first cut, and some further rewrites are needed.
295 lines
10 KiB
Common Lisp
295 lines
10 KiB
Common Lisp
;;;; 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))))))))))))
|