This is the first checked-in completely working version. It contains

nearly all concepts and simple implementations thereof needed to get a
simple HTTP/0.9 "compliant" server working (there are some hacks
needed that we don't yet provide, since the correct things will be
added shortly, like complete HTTP/1.1 request parsing.  The hacks
needed are provided as part of the basic HTTP/0.9 server demo in
src/test/basic-demo.cl).

Further work is needed to clean up some things, Entity and Resource
handling needs to be implemented right and less "naive" (the current
implementations are just simple place-holders to get things up and
running).  Connections need to have knowledge of client identity
(passed from the driver, this is implementation-specific stuff).
Logging needs to be implemented (probably as server mixins).
Condition handling needs to generate better responses for HTTP/0.9,
and the division between condition handling and normal handling needs
to be documented/rethought.  Content generation is totally missing
currently and needs to be implemented.  If this is all in place, an
HTTP/1.0 conforming server should be possible, and after porting the
drivers to ACL and LW, we can make a first release.

CLASH.system

@@ -14,13 +14,14 @@
 ;;;; 
 ;;;; 
 
+#+NIL
 (defsystem "CLASH-SYS"
     :source-pathname "src/sys"
     :source-extension "cl"
     :components
     ((:file "package")
-     (:file "mp" :depends-on "package")
+     (:file "mp" :depends-on ("package"))
-     (:file "socket" :depends-on "package")))
+     (:file "socket" :depends-on ("package"))))
 
 (defsystem "CLASH"
     :source-pathname "src"
@@ -31,10 +32,30 @@
 	      :components ((:file "package")))
      (:module "main"
 	      :source-pathname "main"
-	      :components ((:file "url"))
+	      :components ((:file "conditions")
+			   (:file "status-codes")
+			   (:file "url"
+				  :depends-on ("conditions" "status-codes"))
+			   (:file "version"
+				  :depends-on ("conditions" "status-codes"))
+			   (:file "http-io"
+				  :depends-on ("conditions" "status-codes"))
+			   (:file "connection"
+				  :depends-on ("http-io"))
+			   (:file "method")
+			   (:file "namespace"
+				  :depends-on ("url"))
+			   (:file "messages"
+				  :depends-on ("url" "version"))
+			   (:file "entity"
+				  :depends-on ("http-io" "url"))
+			   (:file "resource"
+				  :depends-on ("entity" "method"))
+			   (:file "server"
+				  :depends-on ("namespace" "messages"
+							   "resource")))
 	      :depends-on ("base"))
      (:module "driver"
 	      :source-pathname "drivers"
-	      :components ((:file "simple.cl"))
+	      :components (#+CMU (:file "simple-cmu"))
-	      :depends-on ("base" "main")))
+	      :depends-on ("base" "main"))))
-    :depends-on ("CLASH-SYS"))

src/drivers/simple-cmu.cl

@@ -0,0 +1,65 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; simple-cmu.cl --- Simple HTTP-Server driver for CMU CL
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defun ip-address-string (address)
+  (format nil "~D.~D.~D.~D"
+	  (ldb (byte 8 24) address)
+	  (ldb (byte 8 16) address)
+	  (ldb (byte 8 8)  address)
+	  (ldb (byte 8 0)  address)))
+
+(defun http-listener (port server)
+  (let ((fd (ext:create-inet-listener port)))
+    (unless fd (error "Cannot bind port ~D." port))
+    (unwind-protect
+	 (progn
+	   (setf (process-name *current-process*)
+		 (format nil
+			 "HTTP connection listener on port ~D with server ~A"
+			 port server))
+	   (format t "~&;;; Started lisp connection listener on ~
+                port ~d for server ~A~%" port server)
+	   (loop
+	       ;; Wait for new connection
+	       (process-wait-until-fd-usable fd :input)
+	       #+CLASH-DEBUG
+	       (format t "~&;;; At ~D Got Connection...~%"
+		       (get-internal-real-time))
+	       (multiple-value-bind (new-fd remote-host)
+		   (ext:accept-tcp-connection fd)
+		 #+CLASH-DEBUG
+		 (format t "~&;;; At ~D Have Connection...~%"
+			 (get-internal-real-time))
+		 (let* ((host-entry (ext:lookup-host-entry remote-host))
+			(stream (sys:make-fd-stream new-fd :input t :output t))
+			(connection (make-instance 'simple-connection
+						   :stream stream)))
+		   #+CLASH-DEBUG
+		   (format t "~&;;; At ~D Established Connection...~%"
+			   (get-internal-real-time))
+		   (make-process
+		    #'(lambda ()
+			(serve-connection server connection))
+		    :name (format nil "HTTP connection from ~A"
+				  (if host-entry
+				      (ext:host-entry-name host-entry)
+				      (ip-address-string remote-host))))))))
+      (when fd (unix:unix-close fd)))))
+
+(defun start-http-listener (port server)
+  (make-process #'(lambda () (http-listener port server))))
+
+(defun initialize-clash (&optional (idle-process mp::*initial-process*))
+  (setf mp::*idle-process* idle-process))

src/main/connection.cl

@@ -0,0 +1,43 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; connection.cl --- Object to identify a connection.
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defconstant +connection-states+
+  '(:fresh
+    :read-request :processing-request :write-response :idle
+    :finished :closed)
+  "List of states that a connection can be in.")
+
+(defclass connection ()
+  ((state :initarg :stage :initform :fresh :accessor connection-state)))
+
+(defgeneric connection-stream (connection))
+
+(defgeneric close-connection (connection))
+
+(defmethod close-connection :after ((connection connection))
+  (setf (connection-state connection) :closed))
+
+(defclass simple-connection (connection)
+  ((stream :initarg :stream :reader connection-stream)))
+
+(defmethod close-connection ((connection simple-connection))
+  (handler-case
+      (close (connection-stream connection))
+    (error (condition)
+      #-CLASH-DEBUG nil
+      #+CLASH-DEBUG
+      (format t "~&;;; At ~D Error closing connection ~A:~%;;;   ~A~&"
+	      (get-internal-real-time)
+	      connection condition))))

src/main/entity.cl

@@ -0,0 +1,112 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; entity.cl --- Entity Handling
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defclass 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-base :initarg :content-base :reader entity-content-base)
+   (content-encoding :initarg :content-encoding
+		     :reader entity-content-encoding)
+   (content-language :initarg :content-language
+		     :reader entity-content-language)
+   (content-length :initarg :content-length :reader entity-content-length)
+   (content-location :initarg :content-location
+		     :reader entity-content-location)
+   (content-md5 :initarg :content-md5 :reader entity-content-md5)
+   (content-range :initarg :content-range :reader entity-content-range)
+   (content-type :initarg :content-type :reader entity-content-type)
+   (etag :initarg :etag :reader entity-etag)
+   (expires :initarg :expires :reader entity-expires)
+   (last-modified :initarg :last-modified :reader entity-last-modified)))
+
+(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 (slot-boundp ,obj-sym (quote ,slot))
+	   (with-slots ((,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))))
+
+(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-base "Content-Base"
+      (princ content-base stream))
+    (content-encoding "Content-Encoding"
+      (write-http-element-list-1 content-encoding stream))
+    (content-language "Content-Language"
+      (write-http-element-list-1 content-language stream))
+    (content-length "Content-Length"
+      (format stream "~D" content-length))
+    (content-location "Content-Location"
+      (princ content-location stream))
+    #+NIL
+    (content-md5 "Content-MD5"
+      (write-string (base64-encode-string content-md5) stream))
+    #+NIL
+    (content-range "Content-Range"
+      (princ content-range stream))
+    #+NIL
+    (content-type "Content-Type"
+      (princ content-type stream))
+    #+NIL
+    (etag "ETag"
+      (princ etag stream))
+    #+NIL
+    (expires "Expires"
+      (princ expires stream))
+    #+NIL
+    (last-modified "Last-Modified"
+      (princ last-modified stream))))
+
+
+
+(defclass simple-entity (entity entity-header-mixin/1.1)
+  ((body :initarg :body :reader entity-body :initform nil)))
+
+(defmethod render-entity-body ((entity simple-entity) stream)
+  (etypecase (entity-body entity)
+    (string
+     (with-input-from-string (in-stream (entity-body entity))
+       (loop for line = (read-line in-stream nil nil)
+	     while line
+	     do (write-http-line line stream))))
+    (pathname
+     (with-open-file (in-stream (entity-body entity))
+       (let ((buffer (make-string (file-length in-stream))))
+	 (+ (read-sequence buffer in-stream)
+	    (length (write-sequence buffer stream))))))
+    (function
+     (funcall (entity-body entity) stream))))

src/main/http-io.cl

@@ -0,0 +1,33 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; http-io.cl --- HTTP conforming input and output routines and codecs
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defun read-http-line (stream)
+  (let ((in-line (read-line stream nil nil)))
+    (if in-line
+	(string-right-trim '(#\Return) in-line)
+	in-line)))
+
+(declaim (inline http-terpri))
+(defun http-terpri (stream)
+  (write-char #\Return stream)
+  (write-char #\Newline stream))
+
+(defun write-http-line (string stream)
+  (write-string string stream)
+  (http-terpri stream))
+
+(declaim (inline write-http-element-list-1))
+(defun write-http-element-list-1 (list stream)
+  (format stream "~{~A~^, ~:}" list))

src/main/messages.cl

@@ -0,0 +1,175 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; messages.cl --- HTTP Request and Response messages
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defclass http-message ()
+  ((server :initarg :server :reader http-message-server
+	   :documentation "The server this message belongs to.")))
+
+(defgeneric http-message-version (message)
+  (:documentation "Returns the HTTP-Version of the given message."))
+
+(defgeneric render-http-message (message stream)
+  (:documentation "Render the given message on the stream."))
+
+(defmethod print-object ((object http-message) stream)
+  (if (or *print-readably* *print-escape*)
+      (call-next-method)
+      (render-http-message object stream)))
+
+;;;; Requests
+
+(defclass request (http-message)
+  ((method :initarg :method :reader request-method)
+   (url :initarg :url :reader request-url)))
+
+;;;; Responses
+
+(defclass response (http-message)
+  ((request :initarg :request :reader response-request)
+   (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))
+
+(defmethod create-response ((request request) status-code &rest args)
+  (apply #'create-response-using-server
+	 (http-message-server request)
+	 request
+	 status-code
+	 args))
+
+;;;; Request parsing framework
+(defgeneric parse-request (server stream)
+  (:documentation
+   "Parse a request from the given stream, returning the created
+request object, which references the given server."))
+
+(defmethod parse-request (server stream)
+  (multiple-value-bind (method url version)
+      (parse-request-line stream)
+    (let ((request (make-instance (get-request-class version)
+				  :server server
+				  :method method
+				  :url url)))
+      (parse-request-remainder request stream)
+      request)))
+
+(defun parse-request-line (stream)
+  "Parse a valid request-line from the stream, returning the method,
+url and http-version as a result."
+  (let ((request-line
+	 (loop for line = (read-http-line stream)
+	       while (and line (zerop (length line)))
+	       finally
+	       (if line
+		   (return line)
+		   (error 'simple-clash-error
+			  :code +HTTP-Code-Bad-Request+
+			  :format-control "Got no valid request-line.")))))
+    (flet ((report-error (fmt &rest args)
+	     (error 'simple-clash-error
+		    :code +HTTP-Code-Bad-Request+
+		    :format-control "~? in Request ~S."
+		    :format-arguments (list fmt args request-line))))
+      (loop with method-end = nil
+	    with url-end = nil
+	    with state = :in-method
+	    for pos from 0 below (length request-line)
+	    for char = (char request-line pos)
+	    do
+	    (case state
+	      (:in-method
+	       (when (char= char #\Space)
+		 (setq method-end pos
+		       state :in-method-delimiter)))
+	      (:in-method-delimiter
+	       (setq state :in-url))
+	      (:in-url
+	       (when (char= char #\Space)
+		 (setq url-end pos
+		       state :in-url-delimiter)))
+	      (:in-url-delimiter
+	       (setq state :in-http-version))
+	      (:in-http-version
+	       (unless (find char "HTP/0123456789.")
+		 (report-error "Strange HTTP-Version field"))))
+	    finally
+	    (case state
+	      ((:in-method :in-method-delimiter)
+	       (report-error "No Request-URI"))
+	      (:in-url-delimiter
+	       (report-error "No HTTP-Version in a non-simple Request"))
+	      ((:in-url :in-http-version)
+	       (return
+		 (values (get-method-symbol (subseq request-line 0 method-end))
+			 (parse-url-from-string
+			  (subseq request-line (1+ method-end) url-end))
+			 (if url-end
+			     (parse-http-version
+			      (subseq request-line (1+ url-end)))
+			     nil)))))))))
+
+(defgeneric parse-request-remainder (request stream)
+  (:documentation
+   "Parse the remainder of the request from the given stream, and
+validate the whole request, including method and url."))
+
+;;;; 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)
+    (error 'simple-clash-error
+	   :code +HTTP-Code-Bad-Request+
+	   :format-control
+	   "Bad Request Method ~A for the request's HTTP-Version ~A."
+	   :format-arguments (list (request-method request)
+				   (http-message-version request))))
+  t)
+
+(defclass response/0.9 (response)
+  ((entity :initarg :entity :reader http-message-entity)))
+
+(defmethod get-response-class ((version (eql (get-http-version 0 9))))
+  (find-class 'response/0.9))
+
+(defmethod render-http-message ((message response/0.9) stream)
+  (render-entity-body (http-message-entity message) stream))

src/main/method.cl

@@ -0,0 +1,17 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; method.cl --- HTTP Request Method registry
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defun get-method-symbol (method-string)
+  (intern method-string (symbol-package :initarg)))

src/main/namespace.cl

@@ -0,0 +1,43 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; namespace.cl --- URL Namespace
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; A namespace maps URLs to resources
+;;;; 
+
+(defclass namespace ()
+  ()
+  (:documentation "A namespace defines a mapping from URLs to resources."))
+
+(defgeneric namespace-add-url (namespace url resource)
+  (:documentation "Add a url resource mapping to the given namespace."))
+
+(defgeneric namespace-remove-url (namespace url)
+  (:documentation "Remove a url resource mapping from the given namespace."))
+
+(defgeneric namespace-lookup-url (namespace url)
+  (:documentation
+   "Lookup the resource mapped to the url by the given namespace."))
+
+(defclass simple-namespace (namespace)
+  ((mapping :initform (make-hash-table :test #'equal)
+	    :reader namespace-mapping)))
+
+(defmethod namespace-add-url ((ns simple-namespace) url resource)
+  (setf (gethash (url-significant-string url)
+		 (namespace-mapping ns))
+	resource))
+
+(defmethod namespace-remove-url ((ns simple-namespace) url)
+  (remhash (url-significant-string url) (namespace-mapping ns)))
+
+(defmethod namespace-lookup-url ((ns simple-namespace) url)
+  (gethash (url-significant-string url) (namespace-mapping ns) nil))

src/main/resource.cl

@@ -0,0 +1,47 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; resource.cl --- Definition of a served resource
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; A resource is that which is accessed by a client through a server
+;;;; via an URL ;)
+;;;; 
+
+(defclass resource ()
+  ())
+
+(defgeneric resource-allowed-methods (resource))
+
+(defgeneric access-resource (resource request))
+
+(defgeneric access-resource-using-method (resource request method))
+
+(defmethod access-resource ((resource resource) request)
+  (let ((method (request-method request))
+	(allowed-methods (resource-allowed-methods resource)))
+    (if (member method allowed-methods)
+	(access-resource-using-method resource request method)
+	(create-response request
+			 +HTTP-Code-Method-Not-Allowed+
+			 (make-instance 'simple-entity
+					:allow allowed-methods)))))
+
+(defclass simple-resource (resource)
+  ((content :initarg :content :accessor simple-resource-content)
+   (allowed-methods :allocation :class :initform '(:GET)
+		    :reader resource-allowed-methods)))
+
+(defmethod access-resource-using-method
+    ((resource simple-resource) request (method (eql :GET)))
+  (create-response request +HTTP-Code-OK+
+		   :entity
+		   (make-instance 'simple-entity
+				  :body
+				  (simple-resource-content resource))))

src/main/server.cl

@@ -0,0 +1,127 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; server.cl --- Basic HTTP Server definition
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defclass http-server ()
+  ((namespace :initarg :namespace :accessor http-server-namespace)))
+
+(defgeneric serve-connection (server connection)
+  (:documentation
+   "Let the server serve the connection.  The
+server is responsible for closing the connection on return.  Methods
+on SERVE-CONNECTION may, but are not forced to, use the generic
+functions READ-REQUEST, SERVE-REQUEST and WRITE-RESPONSE to serve the
+connection.  Likewise the server is allowed and not forced to use the
+generic function handle-server-error to handle server errors."))
+
+(defgeneric read-request (server connection)
+  (:method :before (server connection)
+	   (declare (ignorable server))
+	   (setf (connection-state connection) :read-request))
+  (:method :after (server connection)
+	   (declare (ignorable server))
+	   (setf (connection-state connection) :processing-request))
+  (:documentation "Read a request from the connection."))
+
+(defgeneric serve-request (server request)
+  (:documentation
+   "Let the server handle the request, creating a valid response
+object that is to be returned."))
+
+(defgeneric create-response-using-server
+    (server request status-code &rest args)
+  (:documentation "Create an apropriate response object for server and
+request, using the detailed information provided by the resource, via
+CREATE-RESPONSE.  A server must implement apropriate methods for this
+generic function, to ensure conformant generation of response messages."))
+
+(defgeneric write-response (server connection response)
+  (:method :before (server connection response)
+	   (declare (ignorable server response))
+	   (setf (connection-state connection) :write-request))
+  (:method :after (server connection response)
+	   (declare (ignorable server response))
+	   (setf (connection-state connection) :idle))
+  (:documentation
+   "Forward the calculated response object to the connection."))
+
+(defgeneric handle-server-error (server connection condition)
+  (:documentation
+   "Handle the condition that occurred while server served the given
+connection."))
+
+(defmacro with-server-handler ((server connection) &body body)
+  (let ((server-sym (gensym))
+	(connection-sym (gensym)))
+    `(let ((,server-sym ,server)
+	   (,connection-sym ,connection))
+       (catch 'exit-connection
+	 (handler-bind ((error #'(lambda (condition)
+				   (handle-server-error
+				    ,server-sym
+				    ,connection-sym
+				    condition))))
+	   ,@body)))))
+
+(defclass http-server/0.9 (http-server)
+  ()
+  (:default-initargs :namespace (make-instance 'simple-namespace)))
+
+(defmethod serve-connection ((server http-server/0.9) connection)
+  (with-server-handler (server connection)
+    (let* ((request (read-request server connection))
+	   (response (serve-request server request)))
+      (write-response server connection response)))
+  (close-connection connection))
+
+(defmethod read-request ((server http-server/0.9) connection)
+  (parse-request server (connection-stream connection)))
+
+(defmethod serve-request ((server http-server/0.9) request)
+  (let ((resource (namespace-lookup-url (http-server-namespace server)
+					(request-url request))))
+    (unless resource
+      (error 'clash-error :code +HTTP-Code-Not-Found+))
+    (access-resource resource request)))
+
+(defmethod write-response ((server http-server/0.9) connection response)
+  (princ response (connection-stream connection)))
+
+(defmethod write-response :after ((server http-server/0.9) connection response)
+  (declare (ignorable server response))
+  (setf (connection-state connection) :finished))
+
+(defmethod create-response-using-server
+    ((server http-server/0.9) request status-code &rest args)
+  (apply #'make-instance
+	 (get-response-class (get-http-version 0 9))
+	 :server server
+	 :request request
+	 :status-code status-code
+	 args))
+
+(defmethod handle-server-error ((server http-server/0.9) connection condition)
+  (ignore-errors
+    (let ((response (make-instance
+		     'response/0.9
+		     :server server
+		     :status-code
+		     +HTTP-Code-Internal-Server-Error+
+		     :entity
+		     (make-instance 'simple-entity
+				    :body
+				    (format nil
+					    "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>500 Internal Server Error</TITLE>~%</HEAD>~%<BODY>~%<H1>Internal Server Error</H1>~%<P>An internal server error occured:</P>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>" condition)))))
+      (write-response server connection response)))
+  (throw 'exit-connection nil))

src/main/version.cl

@@ -0,0 +1,126 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; version.cl --- HTTP-Version handling
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+;;;; Some typedef for version numbers
+(deftype http-version-number-type ()
+  "Type for HTTP-Version major and minor version numbers."
+  `(integer 0 ,most-positive-fixnum))
+
+(defstruct (http-version (:print-function print-http-version))
+  (major 0 :read-only t :type http-version-number-type)
+  (minor 0 :read-only t :type http-version-number-type))
+
+;;; http-version objects are interned here, so that at most one
+;;; version object for each version will ever be present in the
+;;; system.  This saves space and makes keying of the http-version
+;;; by EQL tractable, which is quite useful.
+
+(defvar *interned-http-version-hash*
+  (make-hash-table :test #'equal))
+
+(defun get-http-version (major minor)
+  "Get the http-version object corresponding to major and minor
+version numbers.  This will retrieve any interned http-version for
+those numbers, or create, intern and return a new http-version
+object."
+  (check-type major http-version-number-type)
+  (check-type minor http-version-number-type)
+  (let* ((version-string (format nil "HTTP/~D.~D" major minor))
+	 (http-version (gethash version-string
+				*interned-http-version-hash* nil)))
+    (or http-version
+	(setf (gethash version-string *interned-http-version-hash*)
+	      (make-http-version :major major :minor minor)))))
+
+(defun parse-http-version (string)
+  "Parse the HTTP-Version string given, returning the HTTP-VERSION
+structure representing that version. If parsing fails, signals a
+clash-error indicating so.  The recognized syntax as per RFC 2068:
+
+   The version of an HTTP message is indicated by an HTTP-Version field
+   in the first line of the message.
+
+          HTTP-Version   = \"HTTP\" \"/\" 1*DIGIT \".\" 1*DIGIT
+
+   Note that the major and minor numbers MUST be treated as separate
+   integers and that each may be incremented higher than a single digit.
+   Thus, HTTP/2.4 is a lower version than HTTP/2.13, which in turn is
+   lower than HTTP/12.3. Leading zeros MUST be ignored by recipients and
+   MUST NOT be sent."
+  (flet ((report-error ()
+	   (error 'simple-clash-error
+		  :code +HTTP-Code-Bad-Request+
+		  :format-control "Bad HTTP-Version string ~S."
+		  :format-arguments (list string))))
+    ;; Try looking up the http-version object if it exists already
+    (let ((http-version (gethash string *interned-http-version-hash* nil)))
+      (when http-version
+	;; We got one, so this is obviously a correct version string,
+	;; so we can just return the corresponding http-version object.
+	(return-from parse-http-version http-version)))
+    
+    ;; Look-Up failed, so we have to do it the hard way by parsing.
+    (unless (and (>= (length string) 8)
+		 (string= string "HTTP/" :end1 5)
+		 (digit-char-p (char string 5)))
+      (report-error))
+    (multiple-value-bind (major rest-pos)
+	(parse-integer string :start 5 :junk-allowed t)
+      (unless (and major
+		   (> rest-pos 5)
+		   (<= rest-pos (- (length string) 2))
+		   (char= (char string rest-pos) #\.)
+		   (digit-char-p (char string (1+ rest-pos))))
+	(report-error))
+      (multiple-value-bind (minor final-pos)
+	  (parse-integer string :start (1+ rest-pos) :junk-allowed t)
+	(unless (and minor (= final-pos (length string)))
+	  (report-error))
+	;; Parsed successfully, construct, intern and return the
+	;; corresponding http-version object:
+	(setf (gethash string *interned-http-version-hash*)
+	      (make-http-version :major major :minor minor))))))
+
+(defun format-http-version (version-object)
+  "Format the given major and minor versions into a HTTP-Version string, as described by RFC 2068, and as recognized by `PARSE-HTTP-VERSION':
+
+   The version of an HTTP message is indicated by an HTTP-Version field
+   in the first line of the message.
+
+          HTTP-Version   = \"HTTP\" \"/\" 1*DIGIT \".\" 1*DIGIT
+
+   Note that the major and minor numbers MUST be treated as separate
+   integers and that each may be incremented higher than a single digit.
+   Thus, HTTP/2.4 is a lower version than HTTP/2.13, which in turn is
+   lower than HTTP/12.3. Leading zeros MUST be ignored by recipients and
+   MUST NOT be sent."
+  (format nil "HTTP/~D.~D"
+	  (http-version-major version-object)
+	  (http-version-minor version-object)))
+
+(defun print-http-version (object stream depth)
+  (declare (ignore depth))
+  (cond
+    ((or *print-readably* *print-escape*)
+     (if *read-eval*
+	 (format stream "#.(get-http-version ~D ~D)"
+		 (http-version-major object)
+		 (http-version-minor object))
+	 (print-unreadable-object (object stream :type t)
+	   (format stream "~D.~D"
+		   (http-version-major object)
+		   (http-version-minor object)))))
+    (t
+     (write-string (format-http-version object) stream))))

src/package.cl

@@ -14,5 +14,5 @@
 ;;;; 
 
 (defpackage "CLASH"
-    (:USE :CL)
+    (:USE :CL #+CMU :MP)
   (:EXPORT "+HTTP-CODE-NO-CONTENT+"))

src/test/basic-demo.cl

@@ -0,0 +1,82 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; basic-demo.cl --- Basic server demonstration
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; This set's up a very basic HTTP/0.9 server on CMU CL.
+;;;; 
+
+;;; Define basic online logging mixin
+
+(defclass basic-logging-mixin ()
+  ((stream :initarg :stream :initform *standard-output*
+	   :accessor basic-logging-stream)))
+
+(defmethod serve-connection :before ((server basic-logging-mixin) connection)
+  (format (basic-logging-stream server)
+	  "~&;;; At ~D Started serving of ~A~%"
+	  (get-internal-real-time) connection))
+
+(defmethod serve-connection :after ((server basic-logging-mixin) connection)
+  (format (basic-logging-stream server)
+	  "~&;;; At ~D Finished serving of ~A~%"
+	  (get-internal-real-time) connection))
+
+;;; Fudge default request class
+(defmethod get-request-class (version)
+  (find-class 'request/0.9))
+
+;;; Define Server class
+(defclass my-server (http-server/0.9 basic-logging-mixin)
+  ())
+
+(defvar *my-server* (make-instance 'my-server))
+
+;;; Populate Server Namespace
+
+(defvar *main-visits* 0
+  "Number of visits to the main page.")
+
+(defun render-main-page (s)
+  (write-line "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">" s)
+  (write-line "<HTML><HEAD>" s)
+  (write-line
+   "<TITLE>CLASH - The Common Lisp Adaptable Simple HTTP server</TITLE>" s)
+  (write-line "</HEAD>" s)
+  (write-line "<BODY BGCOLOR=\"#000000\" TEXT=\"#28b4d9\">" s)
+  (write-line "<CENTER><P>" s)
+  (write-line
+   "<IMG SRC=\"pic/logo.jpg\" ALT=\"CLASH Logo\">" s)
+  (write-line "</P></CENTER>" s)
+  (write-line "<CENTER><H1>Welcom to CLASH!</H1></CENTER>" s)
+  (format s "<HR><P>You are visitor number ~D.</P>" (incf *main-visits*))
+  (write-line "</BODY></HTML>" s))
+
+(let* ((c-path #.*compile-file-pathname*)
+       (base-path (make-pathname
+		   :directory (butlast (pathname-directory c-path) 2)
+		   :name nil :type nil :version nil
+		   :defaults c-path))
+       (namespace (http-server-namespace *my-server*))
+       (main-page (make-instance 'simple-resource
+				 :content #'render-main-page)))
+  (namespace-add-url
+   namespace (parse-url-from-string "/pic/logo.jpg")
+   (make-instance 'simple-resource
+		  :content (merge-pathnames "doc/logo2.jpg" base-path)))
+  (namespace-add-url namespace (parse-url-from-string "/index.html")
+		     main-page)
+  (namespace-add-url namespace (parse-url-from-string "/")
+		     main-page))
+
+;;; Start everything
+
+(start-http-listener 8080 *my-server*)
+(initialize-clash)