diff --git a/CLASH.system b/CLASH.system index 4acdb32..bbffac0 100644 --- a/CLASH.system +++ b/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 "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")))) diff --git a/src/drivers/simple-cmu.cl b/src/drivers/simple-cmu.cl new file mode 100644 index 0000000..c88c8c1 --- /dev/null +++ b/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)) diff --git a/src/main/connection.cl b/src/main/connection.cl new file mode 100644 index 0000000..ffaef8c --- /dev/null +++ b/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)))) diff --git a/src/main/entity.cl b/src/main/entity.cl new file mode 100644 index 0000000..7a2c465 --- /dev/null +++ b/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)))) diff --git a/src/main/http-io.cl b/src/main/http-io.cl new file mode 100644 index 0000000..92e2220 --- /dev/null +++ b/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)) diff --git a/src/main/messages.cl b/src/main/messages.cl new file mode 100644 index 0000000..8d7e4c1 --- /dev/null +++ b/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)) diff --git a/src/main/method.cl b/src/main/method.cl new file mode 100644 index 0000000..56109f8 --- /dev/null +++ b/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))) diff --git a/src/main/namespace.cl b/src/main/namespace.cl new file mode 100644 index 0000000..f8c7b58 --- /dev/null +++ b/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)) diff --git a/src/main/resource.cl b/src/main/resource.cl new file mode 100644 index 0000000..d8702ae --- /dev/null +++ b/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)))) diff --git a/src/main/server.cl b/src/main/server.cl new file mode 100644 index 0000000..2a09338 --- /dev/null +++ b/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 + "~%~%500 Internal Server Error~%~%~%

Internal Server Error

~%

An internal server error occured:

~%
~%~A~%
~%" condition))))) + (write-response server connection response))) + (throw 'exit-connection nil)) diff --git a/src/main/version.cl b/src/main/version.cl new file mode 100644 index 0000000..df163f7 --- /dev/null +++ b/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)))) diff --git a/src/package.cl b/src/package.cl index 6effc74..1cd295d 100644 --- a/src/package.cl +++ b/src/package.cl @@ -14,5 +14,5 @@ ;;;; (defpackage "CLASH" - (:USE :CL) + (:USE :CL #+CMU :MP) (:EXPORT "+HTTP-CODE-NO-CONTENT+")) diff --git a/src/test/basic-demo.cl b/src/test/basic-demo.cl new file mode 100644 index 0000000..8e9c459 --- /dev/null +++ b/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 "" s) + (write-line "" s) + (write-line + "CLASH - The Common Lisp Adaptable Simple HTTP server" s) + (write-line "" s) + (write-line "" s) + (write-line "

" s) + (write-line + "\"CLASH" s) + (write-line "

" s) + (write-line "

Welcom to CLASH!

" s) + (format s "

You are visitor number ~D.

" (incf *main-visits*)) + (write-line "" 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)