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.

CLASH.system

@@ -42,6 +42,8 @@
 				  :depends-on ("conditions" "status-codes"))
 			   (:file "version"
 				  :depends-on ("conditions" "status-codes"))
+			   (:file "mime"
+				  :depends-on ("conditions" "parsing"))
 			   (:file "buffer"
 				  :depends-on ("conditions"))
 			   (:file "http-io"

src/main/entity.cl

@@ -16,12 +16,20 @@
 (defclass entity ()
   ())
 
+(defgeneric compute-entity-initargs (entity headers)
+  (:method-combination nconc)
+  (:documentation
+   "Given a parsed HTTP header-list, compute the initargs that will be
+used to call `reinitialize-instance' on the entity."))
+
 (defgeneric render-entity-headers (entity stream))
 
 (defgeneric render-entity-body (entity stream))
 
 (defclass entity-header-mixin/1.1 ()
   ((allow :initarg :allow :reader entity-allow)
+   (content-disposition :initarg :content-disposition
+			:reader entity-content-disposition)
    (content-encoding :initarg :content-encoding
 		     :reader entity-content-encoding)
    (content-language :initarg :content-language
@@ -35,10 +43,27 @@
    (expires :initarg :expires :reader entity-expires)
    (last-modified :initarg :last-modified :reader entity-last-modified)))
 
+(defmethod compute-entity-initargs nconc
+    ((entity entity-header-mixin/1.1) headers)
+  (process-http-headers (h v) headers
+    (:allow (mapcar #'get-method-symbol (parse-simple-list v)))
+    (:content-disposition (parse-content-disposition-string v))
+    (:content-encoding (parse-simple-list v))
+    (:content-language (parse-simple-list v))
+    (:content-length (parse-integer v))
+    (:content-location (parse-url-from-string v))
+    (:content-md5 (decode-base64-string v))
+    :content-range
+    (:content-type (parse-content-type-string v))
+    (:expires (parse-http-date v))
+    (:last-modified (parse-http-date v))))
+
 (defmethod render-entity-headers ((e entity-header-mixin/1.1) stream)
   (render-slots (e stream)
     (allow "Allow"
       (write-http-element-list-1 allow stream))
+    (content-disposition "Content-Disposition"
+      (render-content-disposition content-disposition stream))
     (content-encoding "Content-Encoding"
       (write-http-element-list-1 content-encoding stream))
     (content-language "Content-Language"
@@ -46,15 +71,15 @@
     (content-length "Content-Length"
       (format stream "~D" content-length))
     (content-location "Content-Location"
-      (princ content-location stream))
+      (write-string (url-string content-location) stream))
-    #+NIL
     (content-md5 "Content-MD5"
-      (write-string (base64-encode-string content-md5) stream))
+      (write-string (encode-base64-string content-md5) stream))
-    #+NIL
     (content-range "Content-Range"
       (princ content-range stream))
     (content-type "Content-Type"
-      (princ content-type stream))
+      (if (stringp content-type)
+	  (write-string content-type stream)
+	  (render-content-type content-type stream)))
     (expires "Expires"
       (write-string (rfc1123-format-time expires) stream))
     (last-modified "Last-Modified"
@@ -105,13 +130,13 @@
 	      (open (entity-pathname entity) :direction :input)))))
 
 (defclass cached-entity-mixin ()
-  ((body-cache)))
+  ((rendered-body)))
 
 (defmethod render-entity-body :around ((entity cached-entity-mixin) stream)
   (prog1 nil
-    (if (slot-boundp entity 'body-cache)
+    (if (slot-boundp entity 'rendered-body)
-	(write-sequence (slot-value entity 'body-cache) stream)
+	(write-sequence (slot-value entity 'rendered-body) stream)
-	(setf (slot-value entity 'body-cache)
+	(setf (slot-value entity 'rendered-body)
 	      (with-output-to-string (cache-stream)
 		(with-open-stream (combined-stream
 				   (make-broadcast-stream stream cache-stream))
@@ -120,3 +145,99 @@
 (defclass cached-file-entity (cached-entity-mixin file-entity)
   ())
 
+;;; Lazy Entities
+
+(defclass lazy-entity (entity entity-header-mixin/1.1)
+  ((body-stream :initarg :body-stream :reader entity-body-stream)
+   (boundary :initarg :boundary :initform nil :reader lazy-entity-boundary)
+   (forced-p :initform nil :reader lazy-entity-forced-p)
+   (last-part-p :initform nil :reader lazy-entity-last-part-p)
+   (cached-body)))
+
+(defmethod lazy-entity-force ((entity lazy-entity))
+  (unless (lazy-entity-forced-p entity)
+    (cond
+      ((lazy-entity-boundary entity)
+       (setf (slot-value entity 'last-part-p)
+	     (multipart-skip-to-boundary (slot-value entity 'body-stream)
+					 (lazy-entity-boundary entity))))
+      ((slot-boundp entity 'content-length)
+       (with-io-buffer (buffer)
+	 (loop with in-stream = (slot-value entity 'body-stream)
+	       with length = (length buffer)
+	       for rest = (entity-content-length entity) then (- rest read)
+	       for size = (min length rest)
+	       for read = (read-sequence buffer in-stream :end size)
+	       until (zerop (- rest read)))))
+      (t
+       (with-io-buffer (buffer)
+	 (loop with in-stream = (slot-value entity 'body-stream)
+	       for length = (read-sequence buffer in-stream)
+	       until (zerop length)))))
+    (setf (slot-value entity 'forced-p) t)))
+
+(defmethod lazy-entity-copy ((entity lazy-entity) stream)
+  (when (lazy-entity-forced-p entity)
+    (error 'simple-clash-error
+	   :format-control "Trying to re-read forced lazy-entity ~S."
+	   :format-arguments (list entity)))
+  (cond
+    ((lazy-entity-boundary entity)
+     (setf (slot-value entity 'last-part-p)
+	   (multipart-copy-to-boundary stream
+				       (slot-value entity 'body-stream)
+				       (lazy-entity-boundary entity))))
+    ((slot-boundp entity 'content-length)
+     (with-io-buffer (buffer)
+       (loop with in-stream = (slot-value entity 'body-stream)
+	     with length = (length buffer)
+	     for rest = (entity-content-length entity) then (- rest read)
+	     for size = (min length rest)
+	     for read = (read-sequence buffer in-stream :end size)
+	     do
+	     (write-sequence buffer stream :end read)
+	     until (zerop (- rest read)))))
+    (t
+     (with-io-buffer (buffer)
+       (loop with in-stream = (slot-value entity 'body-stream)
+	     for length = (read-sequence buffer in-stream)
+	     until (zerop length)
+	     do
+	     (write-sequence buffer stream :end length)))))
+  (setf (slot-value entity 'forced-p) t))
+
+(defmethod entity-body ((entity lazy-entity))
+  (cond
+    ((slot-boundp entity 'cached-body)
+     (slot-value entity 'cached-body))
+    (t
+     (setf (slot-value entity 'cached-body)
+	   (with-output-to-string (stream)
+	     (lazy-entity-copy entity stream))))))
+
+(defun multipart-create-next-entity (stream class boundary)
+  (let* ((headers (parse-mime-headers stream))
+	 (entity (make-instance class :body-stream stream :boundary boundary)))
+    (apply #'reinitialize-instance entity
+	   (compute-entity-initargs entity headers))))
+
+(defun make-multipart-entity-iterator-fun (entity class)
+  (let ((boundary (mime-type-parameter (entity-content-type entity) :boundary))
+	(stream (entity-body-stream entity))
+	(last-entity nil))
+    (lambda ()
+      (if (and last-entity (lazy-entity-last-part-p last-entity))
+	  nil
+	  (progn
+	    (if (null last-entity)
+		(multipart-skip-to-boundary stream boundary)
+		(lazy-entity-force last-entity))
+	    (setq last-entity
+		  (multipart-create-next-entity stream class boundary)))))))
+
+(defmacro with-multipart-entity-iterator
+    ((name entity &optional (class 'lazy-entity)) &body body)
+  (let ((iterator (gensym (symbol-name '#:with-multipart-entity-iterator-))))
+    `(let ((,iterator (make-multipart-entity-iterator-fun ,entity ',class)))
+       (macrolet ((,name () '(funcall ,iterator)))
+	 ,@body))))

src/main/messages.cl

@@ -315,9 +315,9 @@ used to call `reinitialize-instance'."))
   (multiple-value-bind (initargs rest)
       (process-http-headers (h v) headers
 	(:authorization (parse-authority-string v))
-	:date
+	(:date (parse-http-date v))
 	:from
-	:if-modified-since
+	(:if-modified-since (parse-http-date v))
 	:pragma
 	(:referer (parse-url-from-string v))
 	:user-agent
@@ -335,22 +335,20 @@ used to call `reinitialize-instance'."))
   (if (slot-boundp request 'entity)
       (slot-value request 'entity)
       (setf (slot-value request 'entity)
-	    (read-request-entity request))))
+	    (make-request-entity request))))
 
-(defmethod read-request-entity ((request request/1.0))
+(defgeneric get-request-entity-class (request))
-  (let* ((headers (slot-value request 'entity-headers))
+(defgeneric make-request-entity (request))
-	 (length-cons (assoc "content-length" headers :test #'string-equal))
+
-	 (length (and length-cons (parse-integer (cdr length-cons))))
+(defmethod make-request-entity ((request request/1.0))
-	 (stream (connection-stream (request-connection request))))
+  (let ((entity (make-instance (get-request-entity-class request)))
-    (when length
+	(headers (slot-value request 'entity-headers)))
-      (let ((buffer (make-string length)))
+    (apply #'reinitialize-instance entity
-	(do ((start 0))
+	   :body-stream (connection-stream (request-connection request))
-	    ((>= (incf start (read-sequence buffer stream :start start))
+	   (compute-entity-initargs entity headers))))
-		 length)))
+
-	(make-instance 'string-entity :content-length length
+(defmethod get-request-entity-class ((request request/1.0))
-		       :content-type (cdr (assoc "content-type" headers
+  (find-class 'lazy-entity))
-						 :test #'string-equal))
-		       :body buffer)))))
 
 (defclass response/1.0 (response)
   ((version :allocation :class :initform (get-http-version 1 0)
@@ -374,7 +372,7 @@ used to call `reinitialize-instance'."))
     (pragma "Pragma"
       (format stream "~{~A~^, ~:}" pragma))
     (location "Location"
-      (format stream "~A" location))
+      (princ location stream))
     (server "Server"
       (format stream "~{~A~^ ~}" (server-product-info server)))
     (www-authenticate "WWW-Authenticate"
@@ -384,6 +382,7 @@ used to call `reinitialize-instance'."))
   (when (slot-boundp message 'entity)
     (render-entity-headers (http-message-entity message) stream)
     (http-terpri stream)
-    (unless (and (response-request message)
+    (unless (or (= (response-status-code message) +HTTP-Code-Not-Modified+)
-		 (eq (request-method (response-request message)) :HEAD))
+		(and (response-request message)
+		     (eq (request-method (response-request message)) :HEAD)))
       (render-entity-body (http-message-entity message) stream))))

src/main/method.cl

@@ -13,5 +13,13 @@
 ;;;; 
 ;;;; 
 
+(defconstant +maximum-safe-http-method-length+ 80
+  "This defines the limit we impose on HTTP method names acceptable to
+`get-method-symbol', in order to avoid interning huge stuff into the
+keyword package, and thereby leaking non-negligible amounts of
+memory.")
+
 (defun get-method-symbol (method-string)
+  (when (> (length method-string) +maximum-safe-http-method-length+)
+    (error 'clash-error :code +http-code-bad-request+))
   (intern method-string (symbol-package :initarg)))

src/main/mime.cl

@@ -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))))))))))))

src/main/parsing.cl

@@ -50,6 +50,37 @@
   "Trim HTTP LWS from string."
   (string-trim +HTTP-LWS-Character-Bag+ string))
 
+(declaim (inline skip-forward-lws))
+(defun skip-forward-lws (string start end)
+  (do ((pos start (1+ pos)))
+      ((or (>= pos end) (not (char-lws-p (char string pos))))
+       pos)))
+
+(declaim (inline skip-backward-lws))
+(defun skip-backward-lws (string start end)
+  (do ((pos end (1- pos)))
+      ((or (<= pos start) (not (char-lws-p (char string pos))))
+       pos)))
+
+(declaim (inline skip-forward-to-lws))
+(defun skip-forward-to-lws (string start end)
+  (do ((pos start (1+ pos)))
+      ((or (>= pos end) (char-lws-p (char string pos)))
+       pos)))
+
+(declaim (inline skip-backward-to-lws))
+(defun skip-backward-to-lws (string start end)
+  (do ((pos end (1- pos)))
+      ((or (<= pos start) (char-lws-p (char string pos)))
+       pos)))
+
+(defmacro with-lws-trimmed-bounds ((string-var start-var end-var) &body body)
+  `(let ((,end-var (or ,end-var (length ,string-var))))
+     (let ((,start-var (skip-forward-lws ,string-var ,start-var ,end-var))
+	   (,end-var
+	    (1+ (skip-backward-lws ,string-var ,start-var (1- ,end-var)))))
+       ,@body)))
+
 (defun dequote-string (string)
   "Dequote an HTTP string."
   (delete +HTTP-Quote-Character+ string))
@@ -158,6 +189,8 @@
 (defconstant +Base64-Code-Array+
   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
 
+(defconstant +Base64-Padding-Character+ #\=)
+
 (defun decode-base64-string (string &key (start 0) end)
   (declare (fixnum start) (string string))
   (let ((end (or end (length string))))
@@ -170,7 +203,7 @@
 	    for char = (char string pos)
 	    for value = (position char +Base64-Code-Array+ :test #'char=)
 	    do
-	    (when (and (null value) (char= char #\=))
+	    (when (and (null value) (char= char +Base64-Padding-Character+))
 	      (setq value 0)
 	      (incf padding))
 	    (when value
@@ -189,6 +222,54 @@
 		     :reason
 		     "Base64-Encoding ended on non-block-boundary"))))))
 
+(defun encode-base64-string
+    (string &key (start 0) end use-crlf final-crlf (line-length 76))
+  (declare (fixnum start) (string string))
+  (let ((end (or end (length string))))
+    (declare (fixnum end))
+    (with-output-to-string (stream)
+      (loop with count = 3
+	    with accumulator = 0
+	    with line-count = 0
+	    for pos from start below end
+	    for char = (char string pos)
+	    for value = (char-code char)
+	    do
+	    ;; Snarf and stash byte
+	    (decf count)
+	    (setf (ldb (byte 8 (* count 8)) accumulator) value)
+	    ;; If we've got 24 bits, then output encoded 4-tuple
+	    (when (zerop count)
+	      ;; Check line-length first
+	      (when (> (+ line-count 4) line-length)
+		(when use-crlf (write-char #\Return stream))
+		(write-char #\Newline stream)
+		(setq line-count 0))
+	      ;; Output 4-tuple
+	      (loop for offset from 3 downto 0
+		    for index = (ldb (byte 6 (* offset 6)) accumulator)
+		    do
+		    (incf line-count)
+		    (write-char (aref +Base64-Code-Array+ index) stream))
+	      ;; Reset stuff
+	      (setq accumulator 0 count 3))
+	    finally
+	    ;; If we didn't end on a 24 bit boundary, output rest with padding
+	    (when (< count 3)
+	      ;; Check line-length first
+	      (when (> (+ line-count 4) line-length)
+		(when use-crlf (write-char #\Return stream))
+		(write-char #\Newline stream))
+	      (loop for offset from 3 downto count
+		    for index = (ldb (byte 6 (* offset 6)) accumulator)
+		    do
+		    (write-char (aref +Base64-Code-Array+ index) stream))
+	      (dotimes (i count)
+		(write-char +Base64-Padding-Character+ stream)))
+	    (when final-crlf
+	      (when use-crlf (write-char #\Return stream))
+	      (write-char #\Newline stream))))))
+
 (defun parse-authority-string (string)
   (let* ((scheme-end (position #\Space string))
 	 (scheme (subseq string 0 scheme-end)))
@@ -217,6 +298,163 @@
       (format nil "~A, ~2,'0D ~A ~4,'0D ~2,'0D:~2,'0D:~2,'0D GMT"
 	      wkday date full-month year hour minute second))))
 
+(defun parse-http-time (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (unless (= 8 (- end start))
+      (error 'clash-syntax-error :fragment (subseq string start end)
+	     :reason
+	     "Invalid length for http-time field (too short or too long)"))
+    (handler-case
+	(let ((hour (parse-integer string :start start :end (+ start 2)))
+	      (min (parse-integer string :start (+ start 3) :end (+ start 5)))
+	      (sec (parse-integer string :start (+ start 6) :end (+ start 8))))
+	  (assert (and (<= 0 hour 23) (<= 0 min 59) (<= 0 sec 59)
+		       (char= (char string (+ start 2)) #\:)
+		       (char= (char string (+ start 5)) #\:)))
+	  (values hour min sec))
+      (error ()
+	(error 'clash-syntax-error :fragment (subseq string start end)
+	       :readson "Invalid http-time")))))
+
+(defun parse-http-day (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (unless (<= 1 (- end start) 2)
+      (error 'clash-syntax-error :fragment (subseq string start end)
+	     :reason
+	     "Invalid length for day field (too short or too long)"))
+    (handler-case
+	(let ((day (parse-integer string :start start :end end)))
+	  (assert (<= 1 day 31))
+	  day)
+      (error ()
+	(error 'clash-syntax-error :fragment (subseq string start end)
+	       :readson "Invalid http-date day")))))
+
+(defconstant +http-date-month-names+
+  '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+
+(defun lookup-month-by-name (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (unless (= 3 (- end start))
+      (error 'clash-syntax-error :fragment (subseq string start end)
+	     :reason
+	     "Invalid length for month field (too short or too long)"))
+    (or
+     (loop for month-name in +http-date-month-names+
+	   for month from 1
+	   thereis (when (string= string month-name :start1 start :end1 end)
+		     month))
+     (error 'clash-syntax-error :fragment (subseq string start end)
+	    :reason "Unknown month name in http-date"))))
+
+(defun parse-http-year (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (case (- end start)
+      (4
+       (handler-case (parse-integer string :start start :end end)
+	 (error ()
+	   (error 'clash-syntax-error :fragment (subseq string start end)
+		  :readson "Invalid http-date year"))))
+      (2
+       (handler-case
+	   (let ((year (parse-integer string :start start :end end)))
+	     (+ year (if (< year 50)
+			 2000
+			 1900)))
+	 (error ()
+	   (error 'clash-syntax-error :fragment (subseq string start end)
+		  :readson "Invalid http-date year"))))
+      (t
+       (error 'clash-syntax-error :fragment (subseq string start end)
+	      :reason
+	      "Invalid length for year field (too short or too long)")))))
+
+(defun parse-rfc1123-date (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (unless (= 29 (- end start))
+      (error 'clash-syntax-error :fragment (subseq string start end)
+	     :reason
+	     "Invalid length for rfc1123-date (too short or too long)"))
+    (let ((day (parse-http-day string (+ start 5) (+ start 7)))
+	  (month (lookup-month-by-name string (+ start 8) (+ start 11)))
+	  (year (parse-http-year string (+ start 12) (+ start 16))))
+      (multiple-value-bind (hour min sec)
+	  (parse-http-time string (+ start 17) (+ start 25))
+	(unless (string= string " GMT" :start1 (+ start 25) :end1 end)
+	  (error 'clash-syntax-error :fragment (subseq string start end)
+		 :reason
+		 "Invalid time-zone (must be GMT)"))
+	(let ((result (encode-universal-time sec min hour day month year 0)))
+	  (multiple-value-bind (sec2 min2 hour2 day2 month2 year2)
+	      (decode-universal-time result 0)
+	    (unless (and (= sec sec2) (= min min2) (= hour hour2)
+			 (= day day2) (= month month2) (= year year2))
+	      (error 'clash-syntax-error :fragment (subseq string start end)
+		     :reason
+		     "Ambiguous rfc1123-date specification")))
+	  result)))))
+
+(defun parse-rfc850-date (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (let ((day-end (position #\, string :start start :end end)))
+      (unless (and day-end (= 24 (- end day-end))
+		   (<= 6 (- day-end start) 9))
+	(error 'clash-syntax-error :fragment (subseq string start end)
+	       :reason
+	       "Invalid length for rfc850-date (too short or too long)"))
+      (let ((day (parse-http-day string (+ day-end 2) (+ day-end 4)))
+	    (month (lookup-month-by-name string (+ day-end 5) (+ day-end 8)))
+	    (year (parse-http-year string (+ day-end 9) (+ day-end 11))))
+	(multiple-value-bind (hour min sec)
+	    (parse-http-time string (+ day-end 12) (+ day-end 20))
+	  (unless (string= string " GMT" :start1 (+ day-end 20) :end1 end)
+	    (error 'clash-syntax-error :fragment (subseq string start end)
+		   :reason
+		   "Invalid time-zone (must be GMT)"))
+	  (let ((result (encode-universal-time sec min hour day month year 0)))
+	    (multiple-value-bind (sec2 min2 hour2 day2 month2 year2)
+		(decode-universal-time result 0)
+	      (unless (and (= sec sec2) (= min min2) (= hour hour2)
+			   (= day day2) (= month month2) (= year year2))
+		(error 'clash-syntax-error :fragment (subseq string start end)
+		       :reason
+		       "Ambiguous rfc850-date specification")))
+	    result))))))
+
+(defun parse-asctime-date (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (unless (= 24 (- end start))
+      (error 'clash-syntax-error :fragment (subseq string start end)
+	     :reason
+	     "Invalid length for asctime-date (too short or too long)"))
+    (let ((day (parse-http-day string (+ start 8) (+ start 10)))
+	  (month (lookup-month-by-name string (+ start 4) (+ start 7)))
+	  (year (parse-http-year string (+ start 20) (+ start 24))))
+      (multiple-value-bind (hour min sec)
+	  (parse-http-time string (+ start 11) (+ start 19))
+	(let ((result (encode-universal-time sec min hour day month year 0)))
+	  (multiple-value-bind (sec2 min2 hour2 day2 month2 year2)
+	      (decode-universal-time result 0)
+	    (unless (and (= sec sec2) (= min min2) (= hour hour2)
+			 (= day day2) (= month month2) (= year year2))
+	      (error 'clash-syntax-error :fragment (subseq string start end)
+		     :reason
+		     "Ambiguous asctime-date specification")))
+	  result)))))
+
+(defun parse-http-date (string &optional (start 0) (end (length string)))
+  (with-lws-trimmed-bounds (string start end)
+    (unless (> (- end start) 3)
+      (error 'clash-syntax-error :fragment (subseq string start end)
+	     :reason "Invalid length for HTTP-date (too short)"))
+    (case (char string (+ start 3)) ; see RFC for grammar
+      (#\,     ; rfc1123-date
+       (parse-rfc1123-date string start end))
+      (#\Space ; asctime-date
+       (parse-asctime-date string start end))
+      (t       ; Must be an rfc850-date
+       (parse-rfc850-date string start end)))))
+
 (defun merge-multiple-keys (a-list &key (test #'eql))
   "Merge multiple entries in an a-list into one entry which contains
 the list of values.  All other entries are kept."

src/main/resource.cl

@@ -28,10 +28,22 @@
 (defmethod access-resource ((resource resource) request)
   (let ((method (request-method request))
 	(allowed-methods (resource-allowed-methods resource)))
-    (if (member method allowed-methods)
+    (unless (member method allowed-methods)
-	(access-resource-using-method resource request method)
       (error 'clash-error :code +HTTP-Code-Method-Not-Allowed+
-	       :entity-initargs (list :allow allowed-methods)))))
+	     :entity-initargs (list :allow allowed-methods)))
+    (let ((response (access-resource-using-method resource request method)))
+      ;; Handle Conditional-Get as per RFC 1945
+      (when (and (eq method :GET)
+		 (header-exists-p request 'if-modified-since)
+		 (= (response-status-code response) +HTTP-Code-Ok+)
+		 (slot-boundp response 'entity)
+		 (header-exists-p (http-message-entity response)
+				  'last-modified)
+		 (<= (entity-last-modified (http-message-entity response))
+		     (request-if-modified-since request)
+		     (get-universal-time)))
+	(setf (slot-value response 'status-code) +HTTP-Code-Not-Modified+))
+      response)))
 
 (defclass static-resource (resource)
   ((entity :initarg :entity :accessor static-resource-entity)

src/package.cl

@@ -114,6 +114,10 @@
    #:get-http-version
    #:parse-http-version
    #:format-http-version
+   ;; MIME
+   #:mime-syntax-error
+   #:mime-type-parameter
+   #:mime-disposition-parameter
    ;; Buffer
    #:*default-io-buffer-size*
    #:with-io-buffer
@@ -177,6 +181,7 @@
    #:render-entity-body
    #:entity-header-mixin/1.1
    #:entity-allow
+   #:entity-content-disposition
    #:entity-content-encoding
    #:entity-content-language
    #:entity-content-length
@@ -193,6 +198,10 @@
    #:entity-body
    #:file-entity
    #:entity-pathname
+   #:lazy-entity
+   #:lazy-entity-force
+   #:lazy-entity-copy
+   #:with-multipart-entity-iterator
    ;; Resource
    #:resource
    #:resource-allowed-methods