Extensive rewrite of parsing routines, most parsable headers in
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.
This commit is contained in:
294
src/main/mime.cl
Normal file
294
src/main/mime.cl
Normal file
@ -0,0 +1,294 @@
|
||||
;;;; 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))))))))))))
|
||||
Reference in New Issue
Block a user