Modified the selection of request and response classes to take into
account the server we are servicing, so that each server only sees and creates request/response classes he knows he can handle. This also makes it possible to add request/response classes in a running system, and to run servers of different versions side-by-side in an image without affecting each other...
This commit is contained in:
@ -75,10 +75,11 @@ request object, which references the given server."))
|
|||||||
(defmethod parse-request (server stream)
|
(defmethod parse-request (server stream)
|
||||||
(multiple-value-bind (method url version)
|
(multiple-value-bind (method url version)
|
||||||
(parse-request-line stream)
|
(parse-request-line stream)
|
||||||
(let ((request (make-instance (get-request-class version)
|
(let ((request (make-instance
|
||||||
:server server
|
(get-request-class-using-server server version)
|
||||||
:method method
|
:server server
|
||||||
:url url)))
|
:method method
|
||||||
|
:url url)))
|
||||||
(parse-request-remainder request stream)
|
(parse-request-remainder request stream)
|
||||||
request)))
|
request)))
|
||||||
|
|
||||||
|
|||||||
@ -34,6 +34,11 @@ generic function handle-server-error to handle server errors."))
|
|||||||
(setf (connection-state connection) :processing-request))
|
(setf (connection-state connection) :processing-request))
|
||||||
(:documentation "Read a request from the connection."))
|
(:documentation "Read a request from the connection."))
|
||||||
|
|
||||||
|
(defgeneric get-request-class-using-server (server version)
|
||||||
|
(:documentation
|
||||||
|
"Based on the version given, return the appropriate class for the
|
||||||
|
request."))
|
||||||
|
|
||||||
(defgeneric serve-request (server request)
|
(defgeneric serve-request (server request)
|
||||||
(:documentation
|
(:documentation
|
||||||
"Let the server handle the request, creating a valid response
|
"Let the server handle the request, creating a valid response
|
||||||
@ -46,6 +51,13 @@ request, using the detailed information provided by the resource, via
|
|||||||
CREATE-RESPONSE. A server must implement apropriate methods for this
|
CREATE-RESPONSE. A server must implement apropriate methods for this
|
||||||
generic function, to ensure conformant generation of response messages."))
|
generic function, to ensure conformant generation of response messages."))
|
||||||
|
|
||||||
|
(defgeneric get-response-class-using-server (server request)
|
||||||
|
(:documentation
|
||||||
|
"Return the class to be used in creating the response object based
|
||||||
|
on the server and the class of the request object passed. This shall
|
||||||
|
be used by `create-response-using-server' to determine the class to be
|
||||||
|
passed to `make-instance'."))
|
||||||
|
|
||||||
(defgeneric write-response (server connection response)
|
(defgeneric write-response (server connection response)
|
||||||
(:method :before (server connection response)
|
(:method :before (server connection response)
|
||||||
(declare (ignorable server response))
|
(declare (ignorable server response))
|
||||||
@ -88,6 +100,9 @@ connection."))
|
|||||||
(defmethod read-request ((server http-server/0.9) connection)
|
(defmethod read-request ((server http-server/0.9) connection)
|
||||||
(parse-request server (connection-stream 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 http-server/0.9) request)
|
||||||
(let ((resource (namespace-lookup-url (http-server-namespace server)
|
(let ((resource (namespace-lookup-url (http-server-namespace server)
|
||||||
(request-url request))))
|
(request-url request))))
|
||||||
@ -105,12 +120,15 @@ connection."))
|
|||||||
(defmethod create-response-using-server
|
(defmethod create-response-using-server
|
||||||
((server http-server/0.9) request status-code &rest args)
|
((server http-server/0.9) request status-code &rest args)
|
||||||
(apply #'make-instance
|
(apply #'make-instance
|
||||||
(get-response-class (get-http-version 0 9))
|
(get-response-class-using-server server request)
|
||||||
:server server
|
:server server
|
||||||
:request request
|
:request request
|
||||||
:status-code status-code
|
:status-code status-code
|
||||||
args))
|
args))
|
||||||
|
|
||||||
|
(defmethod get-response-class-using-server ((server http-server/0.9) request)
|
||||||
|
(get-response-class (get-http-version 0 9)))
|
||||||
|
|
||||||
(defmethod handle-server-error ((server http-server/0.9) connection condition)
|
(defmethod handle-server-error ((server http-server/0.9) connection condition)
|
||||||
(ignore-errors
|
(ignore-errors
|
||||||
(let ((response (make-instance
|
(let ((response (make-instance
|
||||||
|
|||||||
@ -29,10 +29,6 @@
|
|||||||
"~&;;; At ~D Finished serving of ~A~%"
|
"~&;;; At ~D Finished serving of ~A~%"
|
||||||
(get-internal-real-time) connection))
|
(get-internal-real-time) connection))
|
||||||
|
|
||||||
;;; Fudge default request class
|
|
||||||
(defmethod get-request-class (version)
|
|
||||||
(find-class 'request/0.9))
|
|
||||||
|
|
||||||
;;; Define Server class
|
;;; Define Server class
|
||||||
(defclass my-server (http-server/0.9 basic-logging-mixin)
|
(defclass my-server (http-server/0.9 basic-logging-mixin)
|
||||||
())
|
())
|
||||||
@ -55,7 +51,7 @@
|
|||||||
(write-line
|
(write-line
|
||||||
"<IMG SRC=\"pic/logo.jpg\" ALT=\"CLASH Logo\">" s)
|
"<IMG SRC=\"pic/logo.jpg\" ALT=\"CLASH Logo\">" s)
|
||||||
(write-line "</P></CENTER>" s)
|
(write-line "</P></CENTER>" s)
|
||||||
(write-line "<CENTER><H1>Welcom to CLASH!</H1></CENTER>" s)
|
(write-line "<CENTER><H1>Welcome to CLASH!</H1></CENTER>" s)
|
||||||
(format s "<HR><P>You are visitor number ~D.</P>" (incf *main-visits*))
|
(format s "<HR><P>You are visitor number ~D.</P>" (incf *main-visits*))
|
||||||
(write-line "</BODY></HTML>" s))
|
(write-line "</BODY></HTML>" s))
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user