diff --git a/src/main/server.cl b/src/main/server.cl index 63589b9..920aa3a 100644 --- a/src/main/server.cl +++ b/src/main/server.cl @@ -16,6 +16,20 @@ (defclass http-server () ((namespace :initarg :namespace :accessor http-server-namespace))) +(defgeneric export-resource (server url resource-class &rest initargs) + (:documentation + "Create an instance of the given `resource-class' using the +supplied `initargs', and add the created resource to the namespace of +the given `server' at the given `url' and return it.")) + +(defmethod export-resource + ((server http-server) url resource-class &rest initargs) + (namespace-add-url (http-server-namespace server) + (ctypecase url + (url url) + (string (parse-url-from-string url))) + (apply #'make-instance resource-class initargs))) + (defgeneric serve-connection (server connection) (:documentation "Let the server serve the connection. The @@ -68,6 +82,18 @@ passed to `make-instance'.")) (:documentation "Forward the calculated response object to the connection.")) +(defgeneric write-response-to-request (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 @@ -86,39 +112,33 @@ connection.")) condition)))) ,@body))))) -(defclass http-server/0.9 (http-server) - () - (:default-initargs :namespace (make-instance 'simple-namespace))) +;;; Simple Server -(defmethod serve-connection ((server http-server/0.9) connection) +(defclass simple-http-server (http-server) + ()) + +(defmethod serve-connection ((server simple-http-server) 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) +(defmethod read-request ((server simple-http-server) connection) (parse-request server (connection-stream connection))) -(defmethod get-request-class-using-server ((server http-server/0.9) version) - (get-request-class nil)) - -(defmethod serve-request ((server http-server/0.9) request) +(defmethod serve-request ((server simple-http-server) 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) +(defmethod write-response ((server simple-http-server) 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) + ((server simple-http-server) request status-code &rest args) (apply #'make-instance (get-response-class-using-server server request) :server server @@ -126,8 +146,23 @@ connection.")) :status-code status-code args)) +;;; Basic 0.9 server + +(defclass http-server/0.9 (simple-http-server) + () + (:default-initargs :namespace (make-instance 'hierarchical-namespace))) + +(defmethod get-request-class-using-server ((server http-server/0.9) version) + (declare (ignore version)) + (find-class 'request/0.9)) + +(defmethod write-response :after ((server http-server/0.9) connection response) + (declare (ignorable server response)) + (setf (connection-state connection) :finished)) + (defmethod get-response-class-using-server ((server http-server/0.9) request) - (get-response-class (get-http-version 0 9))) + (declare (ignore request)) + (find-class 'response/0.9)) (defmethod handle-server-error ((server http-server/0.9) connection condition) (ignore-errors @@ -137,9 +172,72 @@ connection.")) :status-code +HTTP-Code-Internal-Server-Error+ :entity - (make-instance 'simple-entity + (make-instance 'string-entity :body (format nil "~%
~%An internal server error occured:
~%~%~A~%~%" condition))))) (write-response server connection response))) (throw 'exit-connection nil)) + + +;;;; HTTP/1.0 + +(defclass http-server/1.0 (simple-http-server) + () + (:default-initargs :namespace (make-instance 'hierarchical-namespace))) + +(defmethod get-request-class-using-server + ((server http-server/1.0) (version (eql (get-http-version 0 9)))) + (find-class 'request/0.9)) + +(defmethod get-request-class-using-server + ((server http-server/1.0) (version null)) + (find-class 'request/0.9)) + +(defmethod get-request-class-using-server + ((server http-server/1.0) version) + (if (= 1 (http-version-major version)) + (find-class 'request/1.0) + (error 'clash-error :code +HTTP-Code-HTTP-Version-Not-Supported+))) + +(defmethod get-response-class-using-server + ((server http-server/1.0) (request request/0.9)) + (find-class 'response/0.9)) + +(defmethod get-response-class-using-server + ((server http-server/1.0) (request request/1.0)) + (find-class 'response/1.0)) + +(defmethod handle-server-error ((server http-server/1.0) connection condition) + (ignore-errors + (let ((response + (typecase condition + (clash-error + (apply #'make-instance + 'response/1.0 + :server server + :status-code (clash-error-code condition) + :entity + (apply #'make-instance + 'string-entity + :body + (format nil "~%~%
~A
~%" + (clash-error-code condition) + (HTTP-Code-Description (clash-error-code condition)) + (HTTP-Code-Description (clash-error-code condition)) + (HTTP-Code-Description (clash-error-code condition))) + (clash-error-entity-initargs condition)) + (clash-error-response-initargs condition))) + (error + (make-instance + 'response/1.0 + :server server + :status-code + +HTTP-Code-Internal-Server-Error+ + :entity + (make-instance 'string-entity + :body + (format nil + "~%~%An internal server error occured:
~%~%~A~%~%" condition))))))) + (write-response server connection response))) + (throw 'exit-connection nil))