Changed request object to carry a reference to the connection object
instead of the stream, in our effort to reduce the passing around of streams. This is also necessary in order to allow request handlers to check for the address and/or hostname of the connection the request came in from. Changed `parse-request' accordingly. TODO: Rendering of messages should probably change over, too. Added handling of Authority request-header, and WWW-Authenticate response-headers. Changed order of response-header rendering to follow RFC guidelines. Added automatic generation of Server response-header, added correct handling and automatic initialization of Date response-header. This should bring us closer to correct and full handling of at least all HTTP/1.0 headers in responses. Request parsing of some headers remains to be done. Added ignore declarations to quiet the compiler.
This commit is contained in:
@ -60,7 +60,7 @@ raised."))
|
|||||||
;;;; Requests
|
;;;; Requests
|
||||||
|
|
||||||
(defclass request (http-message)
|
(defclass request (http-message)
|
||||||
((stream :initarg :stream :reader request-stream)
|
((connection :initarg :connection :reader request-connection)
|
||||||
(method :initarg :method :reader request-method)
|
(method :initarg :method :reader request-method)
|
||||||
(url :initarg :url :reader request-url)))
|
(url :initarg :url :reader request-url)))
|
||||||
|
|
||||||
@ -81,22 +81,23 @@ raised."))
|
|||||||
args))
|
args))
|
||||||
|
|
||||||
;;;; Request parsing framework
|
;;;; Request parsing framework
|
||||||
(defgeneric parse-request (server stream)
|
(defgeneric parse-request (server connection)
|
||||||
(:documentation
|
(:documentation
|
||||||
"Parse a request from the given stream, returning the created
|
"Parse a request from the given connection, returning the created
|
||||||
request object, which references the given server."))
|
request object, which references the given server and connection."))
|
||||||
|
|
||||||
(defmethod parse-request (server stream)
|
(defmethod parse-request (server connection)
|
||||||
|
(let ((stream (connection-stream connection)))
|
||||||
(multiple-value-bind (method url version)
|
(multiple-value-bind (method url version)
|
||||||
(parse-request-line stream)
|
(parse-request-line stream)
|
||||||
(let ((request (make-instance
|
(let ((request (make-instance
|
||||||
(get-request-class-using-server server version)
|
(get-request-class-using-server server version)
|
||||||
:stream stream
|
:connection connection
|
||||||
:server server
|
:server server
|
||||||
:method method
|
:method method
|
||||||
:url url)))
|
:url url)))
|
||||||
(parse-request-remainder request stream)
|
(parse-request-remainder request stream)
|
||||||
request)))
|
request))))
|
||||||
|
|
||||||
(defun parse-request-line (stream)
|
(defun parse-request-line (stream)
|
||||||
"Parse a valid request-line from the stream, returning the method,
|
"Parse a valid request-line from the stream, returning the method,
|
||||||
@ -274,7 +275,8 @@ is appended to the list of unprocessed headers."
|
|||||||
(entity :initarg :entity :reader http-message-entity)))
|
(entity :initarg :entity :reader http-message-entity)))
|
||||||
|
|
||||||
(defmethod initialize-instance :after
|
(defmethod initialize-instance :after
|
||||||
((instance response/0.9) &rest initargs &allow-other-keys)
|
((instance response/0.9) &rest initargs &key &allow-other-keys)
|
||||||
|
(declare (ignorable initargs instance))
|
||||||
t)
|
t)
|
||||||
|
|
||||||
(defmethod render-http-message ((message response/0.9) stream)
|
(defmethod render-http-message ((message response/0.9) stream)
|
||||||
@ -313,7 +315,7 @@ used to call `reinitialize-instance'."))
|
|||||||
(defmethod compute-request-initargs ((request request/1.0) headers)
|
(defmethod compute-request-initargs ((request request/1.0) headers)
|
||||||
(multiple-value-bind (initargs rest)
|
(multiple-value-bind (initargs rest)
|
||||||
(process-http-headers (h v) headers
|
(process-http-headers (h v) headers
|
||||||
:authorization
|
(:authorization (parse-authority-string v))
|
||||||
:date
|
:date
|
||||||
:from
|
:from
|
||||||
:if-modified-since
|
:if-modified-since
|
||||||
@ -340,7 +342,7 @@ used to call `reinitialize-instance'."))
|
|||||||
(let* ((headers (slot-value request 'entity-headers))
|
(let* ((headers (slot-value request 'entity-headers))
|
||||||
(length-cons (assoc "content-length" headers :test #'string-equal))
|
(length-cons (assoc "content-length" headers :test #'string-equal))
|
||||||
(length (and length-cons (parse-integer (cdr length-cons))))
|
(length (and length-cons (parse-integer (cdr length-cons))))
|
||||||
(stream (request-stream request)))
|
(stream (connection-stream (request-connection request))))
|
||||||
(when length
|
(when length
|
||||||
(let ((buffer (make-string length)))
|
(let ((buffer (make-string length)))
|
||||||
(do ((start 0))
|
(do ((start 0))
|
||||||
@ -354,9 +356,11 @@ used to call `reinitialize-instance'."))
|
|||||||
(defclass response/1.0 (response)
|
(defclass response/1.0 (response)
|
||||||
((version :allocation :class :initform (get-http-version 1 0)
|
((version :allocation :class :initform (get-http-version 1 0)
|
||||||
:reader http-message-version)
|
:reader http-message-version)
|
||||||
(date :initarg :date :reader response-date)
|
(date :initarg :date :initform (get-universal-time) :reader response-date)
|
||||||
(location :initarg :location :reader response-location)
|
|
||||||
(pragma :initarg :pragma :reader response-pragma)
|
(pragma :initarg :pragma :reader response-pragma)
|
||||||
|
(location :initarg :location :reader response-location)
|
||||||
|
(www-authenticate :initarg :www-authenticate
|
||||||
|
:reader response-www-authenticate)
|
||||||
(set-cookie :initarg :set-cookie :reader response-set-cookie)
|
(set-cookie :initarg :set-cookie :reader response-set-cookie)
|
||||||
(entity :initarg :entity :reader http-message-entity)))
|
(entity :initarg :entity :reader http-message-entity)))
|
||||||
|
|
||||||
@ -367,11 +371,15 @@ used to call `reinitialize-instance'."))
|
|||||||
(http-terpri stream)
|
(http-terpri stream)
|
||||||
(render-slots (message stream)
|
(render-slots (message stream)
|
||||||
(date "Date"
|
(date "Date"
|
||||||
(format stream "~A" date))
|
(write-string (rfc1123-format-time date) stream))
|
||||||
(location "Location"
|
|
||||||
(format stream "~A" location))
|
|
||||||
(pragma "Pragma"
|
(pragma "Pragma"
|
||||||
(format stream "~{~A~^, ~:}" pragma))
|
(format stream "~{~A~^, ~:}" pragma))
|
||||||
|
(location "Location"
|
||||||
|
(format stream "~A" location))
|
||||||
|
(server "Server"
|
||||||
|
(format stream "~{~A~^ ~}" (server-product-info server)))
|
||||||
|
(www-authenticate "WWW-Authenticate"
|
||||||
|
(format stream "~:{~A realm=~S~@{,~A=~S~}~:^ , ~}" www-authenticate))
|
||||||
(set-cookie "Set-Cookie"
|
(set-cookie "Set-Cookie"
|
||||||
(format stream "~:{~A~@[=~A~]~^;~:}" set-cookie)))
|
(format stream "~:{~A~@[=~A~]~^;~:}" set-cookie)))
|
||||||
(when (slot-boundp message 'entity)
|
(when (slot-boundp message 'entity)
|
||||||
|
|||||||
Reference in New Issue
Block a user