Changes that bring CLASH up to extended HTTP/1.0 support:

Extensive changes to accomodate the new model for message classes and
HTTP versions.  This was necessary because the old model was not as
flexible and concise as hoped, so that supporting multiple http
version became tedious.  The new infrastructure is still a bit of a
work in progress, though, so watch this space.  There's also some work
left purging the reliance on pure streams instead of connections.

src/main/messages.cl

@@ -28,33 +28,47 @@
       (call-next-method)
       (render-http-message object stream)))
 
+(defgeneric header-exists-p (message header)
+  (:documentation
+   "Returns true if the given header exists and is filled-in in the
+given message."))
+
+(defmethod header-exists-p (message header)
+  (and (slot-exists-p message header) (slot-boundp message header)))
+
+(defgeneric header-value (message header)
+  (:documentation
+   "If the given header exists and is available, as determined by
+`header-exists-p', it's value is returned.  Otherwise an error is
+raised."))
+
+(defmethod header-value (message header)
+  (slot-value message header))
+
+(defmacro with-headers (specs message &body body)
+  "This is the equivalent of with-slots on http-messages, using header-value."
+  (loop with message-var = (gensym)
+	for spec in specs
+	for symbol = (if (consp spec) (first spec) spec)
+	for header = (if (consp spec) (second spec) spec)
+	collect `(,symbol (header-value ,message-var ',header)) into clauses
+	finally
+	(return 
+	  `(let ((,message-var ,message))
+	     (symbol-macrolet ,clauses ,@body)))))
+
 ;;;; Requests
 
 (defclass request (http-message)
-  ((method :initarg :method :reader request-method)
+  ((stream :initarg :stream :reader request-stream)
+   (method :initarg :method :reader request-method)
    (url :initarg :url :reader request-url)))
 
 ;;;; Responses
 
 (defclass response (http-message)
-  ((request :initarg :request :reader response-request)
+  ((request :initarg :request :initform nil :reader response-request)
-   (status-code :initarg :status-code :reader response-status-code)
+   (status-code :initarg :status-code :reader response-status-code)))
-   (general-headers :initarg :general-headers
-		    :reader response-general-headers)
-   (response-headers :initarg :response-headers
-		     :reader response-response-headers)
-   (entity :initarg :entity :reader response-entity)))
-
-;;;; Mapping between http-versions and request/response objects
-(defgeneric get-request-class (version)
-  (:documentation
-   "Return the Request class corresponding to the given version, which
-is either a http-version object, or nil, if no http-version was
-supplied in the request."))
-
-(defgeneric get-response-class (version)
-  (:documentation
-   "Return the Response class corresponding to the given version."))
 
 ;;;; Creating responses for requests:
 (defgeneric create-response (request status-code &rest args))
@@ -77,6 +91,7 @@ request object, which references the given server."))
       (parse-request-line stream)
     (let ((request (make-instance
 		    (get-request-class-using-server server version)
+		    :stream stream
 		    :server server
 		    :method method
 		    :url url)))
@@ -132,7 +147,8 @@ url and http-version as a result."
 	       (return
 		 (values (get-method-symbol (subseq request-line 0 method-end))
 			 (parse-url-from-string
-			  (subseq request-line (1+ method-end) url-end))
+			  (subseq request-line (1+ method-end) url-end)
+			  :base "http")
 			 (if url-end
 			     (parse-http-version
 			      (subseq request-line (1+ url-end)))
@@ -143,18 +159,101 @@ url and http-version as a result."
    "Parse the remainder of the request from the given stream, and
 validate the whole request, including method and url."))
 
+;;;; Utility macros for HTTP/1.0 and larger
+
+(defun parse-http-headers (stream)
+  "Parse all HTTP headers from the stream up to the end of the header
+indicated by an empty line and return them as a a-list of header/value
+string pairs for further parsing."
+  (loop for in-line = (read-http-line stream)
+ 	while (and in-line (not (zerop (length in-line))))
+	collect
+	(let ((header-end (position #\: in-line)))
+	  (unless header-end
+	    (error 'simple-clash-error
+		   :code +HTTP-Code-Bad-Request+
+		   :format-control "Missing header separator in line ~S."
+		   :format-arguments (list in-line)))
+	  (loop with header = (subseq in-line 0 header-end)
+		for line = (subseq in-line (1+ header-end))
+		then (read-http-line stream)
+		for value = (string-trim '(#\Space #\Tab) line)
+		then (concatenate 'string value " "
+				  (string-trim '(#\Space #\Tab) line))
+		for next-char = (peek-char nil stream nil #\@)
+		while (or (char= next-char #\Space) (char= next-char #\Tab))
+		finally (return (cons header value))))))
+
+(defun merge-multiple-http-headers (header-alist)
+  "Merge multiply occurring headers into single headers."
+  ;; TODO: Implement properly and tune.  Since duplicated headers
+  ;; occur rarely in practice (only allowable on list headers), this
+  ;; should execute quickly and without consing for non-duplicate
+  ;; headers, and work reasonably for merging duplicates.
+  header-alist)
+
+(defmacro process-http-headers ((header value) headers &body clauses)
+  "Process the headers a-list produced by the `headers' form, as
+specified by the clauses, and return as values the list of processed
+headers and the rest a-list of unprocessed headers.
+
+The clauses are of the form ((string key) . body).  For each header in
+the a-list, if a clause with a matching (string-equal) string form,
+which is evaluated, is found, then body is evaluated in an environment
+where the variables named via `header' and `value' are bound to the
+relevant header and value strings, and the result of evaluating key
+and the implicit progn `body' are appended to the list of processed
+headers.  An empty body will evaluate to the value of `value'.
+
+If no matching clause is found, then a cons of header and value string
+is appended to the list of unprocessed headers."
+
+  (let ((processed (gensym))
+	(remaining (gensym))
+	(cond-clauses
+	 (loop for (clause . body) in (mapcar #'(lambda (x)
+						  (if (consp x)
+						      x
+						      (cons x nil)))
+					      clauses)
+	       for string = (string (if (consp clause) (car clause) clause))
+	       for key = (if (and (consp clause) (cadr clause))
+			     (cadr clause)
+			     (intern (string-upcase string) "KEYWORD"))
+	       collect `((string-equal ,header ,string)
+			 (list ,key (progn ,value ,@body))))))
+    `(loop for (,header . ,value) in ,headers
+           if (cond ,@cond-clauses) nconc it into ,processed
+           else collect (cons ,header ,value) into ,remaining
+           finally (return (values ,processed ,remaining)))))
+
+(defmacro render-slots ((obj stream) &rest clauses)
+  (loop with obj-sym = (gensym)
+	with stream-sym = (gensym)
+	for (slot-spec string . body) in clauses
+	for slot = (if (consp slot-spec) (car slot-spec) slot-spec)
+	for slot-var = (if (consp slot-spec) (cadr slot-spec) slot-spec)
+	collect
+	`(when (header-exists-p ,obj-sym (quote ,slot))
+	   (with-headers ((,slot-var ,slot)) ,obj-sym
+	     (write-string ,string ,stream-sym)
+	     (write-char #\: ,stream-sym)
+	     (write-char #\Space ,stream-sym)
+	     ,@body
+	     (write-char #\Return ,stream-sym)
+	     (write-char #\Newline ,stream-sym)))
+	into clause-list
+	finally
+	(return `(let ((,stream-sym ,stream)
+		       (,obj-sym ,obj))
+		   ,@clause-list))))
+
 ;;;; HTTP/0.9
 
 (defclass request/0.9 (request)
   ((version :allocation :class :initform (get-http-version 0 9)
 	    :reader http-message-version)))
 
-(defmethod get-request-class ((version (eql nil)))
-  (find-class 'request/0.9))
-
-(defmethod get-request-class ((version (eql (get-http-version 0 9))))
-  (find-class 'request/0.9))
-
 (defmethod parse-request-remainder ((request request/0.9) stream)
   (declare (ignore stream))
   (unless (eq (request-method request) :GET)
@@ -166,11 +265,116 @@ validate the whole request, including method and url."))
 				   (http-message-version request))))
   t)
 
-(defclass response/0.9 (response)
+(defmethod request-entity ((request request/0.9))
-  ((entity :initarg :entity :reader http-message-entity)))
+  nil)
 
-(defmethod get-response-class ((version (eql (get-http-version 0 9))))
+(defclass response/0.9 (response)
-  (find-class 'response/0.9))
+  ((version :allocation :class :initform (get-http-version 0 9)
+	    :reader http-message-version)
+   (entity :initarg :entity :reader http-message-entity)))
+
+(defmethod initialize-instance :after
+    ((instance response/0.9) &rest initargs &allow-other-keys)
+  t)
 
 (defmethod render-http-message ((message response/0.9) stream)
   (render-entity-body (http-message-entity message) stream))
+
+;;;; HTTP/1.0
+
+(defclass request/1.0 (request)
+  ((version :allocation :class :initform (get-http-version 1 0)
+	    :reader http-message-version)
+   (authorization :initarg :authorization :reader request-authorization)
+   (cookie :initarg :cookie :reader request-cookie)
+   (date :initarg :date :reader request-date)
+   (from :initarg :from :reader request-from)
+   (if-modified-since :initarg :if-modified-since
+		      :reader request-if-modified-since)
+   (pragma :initarg :pragma :reader request-pragma)
+   (referer :initarg :referer :reader request-referer)
+   (user-agent :initarg :user-agent :reader request-user-agent)
+   (entity)
+   (entity-headers :initarg :entity-headers
+		   :initform nil)))
+
+(defmethod shared-initialize :after
+    ((instance request/1.0) slots &rest args &key host)
+  (declare (ignore slots args))
+  (when host
+    (setf (slot-value instance 'url)
+	  (merge-urls (slot-value instance 'url) host))))
+
+(defgeneric compute-request-initargs (request headers)
+  (:documentation
+   "Given a parsed HTTP header-list, compute the initargs that will be
+used to call `reinitialize-instance'."))
+
+(defmethod compute-request-initargs ((request request/1.0) headers)
+  (multiple-value-bind (initargs rest)
+      (process-http-headers (h v) headers
+	:authorization
+	:date
+	:from
+	:if-modified-since
+	:pragma
+	(:referer (parse-url-from-string v))
+	:user-agent
+	(:cookie (parse-key-value-list v :list-delimiter #\;))
+	(:host (parse-url-from-string (concatenate 'string "http://" v))))
+    (list* :entity-headers rest initargs)))
+
+(defmethod parse-request-remainder ((request request/1.0) stream)
+  (let* ((headers (parse-http-headers stream))
+	 (initargs (compute-request-initargs request headers)))
+    (apply #'reinitialize-instance request initargs)
+    t))
+
+(defmethod request-entity ((request request/1.0))
+  (if (slot-boundp request 'entity)
+      (slot-value request 'entity)
+      (setf (slot-value request 'entity)
+	    (read-request-entity request))))
+
+(defmethod read-request-entity ((request request/1.0))
+  (let* ((headers (slot-value request 'entity-headers))
+	 (length-cons (assoc "content-length" headers :test #'string-equal))
+	 (length (and length-cons (parse-integer (cdr length-cons))))
+	 (stream (request-stream request)))
+    (when length
+      (let ((buffer (make-string length)))
+	(read-sequence buffer stream)
+	(make-instance 'string-entity :content-length length
+		       :content-type (cdr (assoc "content-type" headers
+						 :test #'string-equal))
+		       :body buffer)))))
+
+(defclass response/1.0 (response)
+  ((version :allocation :class :initform (get-http-version 1 0)
+	    :reader http-message-version)
+   (date :initarg :date :reader response-date)
+   (location :initarg :location :reader response-location)
+   (pragma :initarg :pragma :reader response-pragma)
+   (set-cookie :initarg :set-cookie :reader response-set-cookie)
+   (entity :initarg :entity :reader http-message-entity)))
+
+(defmethod render-http-message ((message response/1.0) stream)
+  (format stream "~A ~D ~A" (http-message-version message)
+	  (response-status-code message)
+	  (HTTP-Code-Description (response-status-code message)))
+  (http-terpri stream)
+  (render-slots (message stream)
+    (date "Date"
+      (format stream "~A" date))
+    (location "Location"
+      (format stream "~A" location))
+    (pragma "Pragma"
+      (format stream "~{~A~^, ~:}" pragma))
+    (set-cookie "Set-Cookie"
+      (format stream "~:{~A~@[=~A~]~^;~:}" set-cookie)))
+  (when (slot-boundp message 'entity)
+    (render-entity-headers (http-message-entity message) stream)
+    (http-terpri stream)
+    (unless (and (response-request message)
+		 (eq (request-method (response-request message)) :HEAD))
+      (render-entity-body (http-message-entity message) stream))))