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.
This commit is contained in:
43
src/main/connection.cl
Normal file
43
src/main/connection.cl
Normal 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
112
src/main/entity.cl
Normal 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
33
src/main/http-io.cl
Normal 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
175
src/main/messages.cl
Normal 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
17
src/main/method.cl
Normal 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
43
src/main/namespace.cl
Normal 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
47
src/main/resource.cl
Normal 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
127
src/main/server.cl
Normal 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
126
src/main/version.cl
Normal 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))))
|
||||
Reference in New Issue
Block a user