OSCL/CLASH
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Pierre R. Mai
1999-08-07 17:55:59 +00:00
parent 0a25f68f43
commit e1c4504ede
13 changed files with 898 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

33
CLASH.system
View File

@ -14,13 +14,14 @@
;;;;
;;;;
#+NIL
(defsystem "CLASH-SYS"
:source-pathname "src/sys"
:source-extension "cl"
:components
((:file "package")
(:file "mp" :depends-on "package")
(:file "socket" :depends-on "package")))
(:file "mp" :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"))
:depends-on ("base" "main")))
:depends-on ("CLASH-SYS"))
:components (#+CMU (:file "simple-cmu"))
:depends-on ("base" "main"))))

65
src/drivers/simple-cmu.cl Normal file
View File

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

43
src/main/connection.cl Normal file
View File

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

112
src/main/entity.cl Normal file
View File

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

33
src/main/http-io.cl Normal file
View File

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

175
src/main/messages.cl Normal file
View File

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

17
src/main/method.cl Normal file
View File

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

43
src/main/namespace.cl Normal file
View File

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

47
src/main/resource.cl Normal file
View File

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

127
src/main/server.cl Normal file
View File

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

126
src/main/version.cl Normal file
View File

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

2
src/package.cl
View File

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

82
src/test/basic-demo.cl Normal file
View File

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