Changes that bring CLASH up to extended HTTP/1.0 support:
Added interface to directly export resources from a server. Restructured code and added HTTP/1.0 support. Various miscellaneous changes.
This commit is contained in:
@ -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
|
||||
"<!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))
|
||||
|
||||
|
||||
;;;; 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 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>~D ~A</TITLE>~%</HEAD>~%<BODY>~%<H1>~A</H1>~%<P>~A</P>~%</BODY></HTML>"
|
||||
(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
|
||||
"<!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))
|
||||
|
||||
Reference in New Issue
Block a user