diff --git a/src/main/messages.cl b/src/main/messages.cl index 7b3a443..7609e88 100644 --- a/src/main/messages.cl +++ b/src/main/messages.cl @@ -28,33 +28,47 @@ (call-next-method) (render-http-message object stream))) +(defgeneric header-exists-p (message header) + (:documentation + "Returns true if the given header exists and is filled-in in the +given message.")) + +(defmethod header-exists-p (message header) + (and (slot-exists-p message header) (slot-boundp message header))) + +(defgeneric header-value (message header) + (:documentation + "If the given header exists and is available, as determined by +`header-exists-p', it's value is returned. Otherwise an error is +raised.")) + +(defmethod header-value (message header) + (slot-value message header)) + +(defmacro with-headers (specs message &body body) + "This is the equivalent of with-slots on http-messages, using header-value." + (loop with message-var = (gensym) + for spec in specs + for symbol = (if (consp spec) (first spec) spec) + for header = (if (consp spec) (second spec) spec) + collect `(,symbol (header-value ,message-var ',header)) into clauses + finally + (return + `(let ((,message-var ,message)) + (symbol-macrolet ,clauses ,@body))))) + ;;;; Requests (defclass request (http-message) - ((method :initarg :method :reader request-method) + ((stream :initarg :stream :reader request-stream) + (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.")) + ((request :initarg :request :initform nil :reader response-request) + (status-code :initarg :status-code :reader response-status-code))) ;;;; Creating responses for requests: (defgeneric create-response (request status-code &rest args)) @@ -77,6 +91,7 @@ request object, which references the given server.")) (parse-request-line stream) (let ((request (make-instance (get-request-class-using-server server version) + :stream stream :server server :method method :url url))) @@ -132,7 +147,8 @@ url and http-version as a result." (return (values (get-method-symbol (subseq request-line 0 method-end)) (parse-url-from-string - (subseq request-line (1+ method-end) url-end)) + (subseq request-line (1+ method-end) url-end) + :base "http") (if url-end (parse-http-version (subseq request-line (1+ url-end))) @@ -143,18 +159,101 @@ url and http-version as a result." "Parse the remainder of the request from the given stream, and validate the whole request, including method and url.")) +;;;; Utility macros for HTTP/1.0 and larger + +(defun parse-http-headers (stream) + "Parse all HTTP headers from the stream up to the end of the header +indicated by an empty line and return them as a a-list of header/value +string pairs for further parsing." + (loop for in-line = (read-http-line stream) + while (and in-line (not (zerop (length in-line)))) + collect + (let ((header-end (position #\: in-line))) + (unless header-end + (error 'simple-clash-error + :code +HTTP-Code-Bad-Request+ + :format-control "Missing header separator in line ~S." + :format-arguments (list in-line))) + (loop with header = (subseq in-line 0 header-end) + for line = (subseq in-line (1+ header-end)) + then (read-http-line stream) + for value = (string-trim '(#\Space #\Tab) line) + then (concatenate 'string value " " + (string-trim '(#\Space #\Tab) line)) + for next-char = (peek-char nil stream nil #\@) + while (or (char= next-char #\Space) (char= next-char #\Tab)) + finally (return (cons header value)))))) + +(defun merge-multiple-http-headers (header-alist) + "Merge multiply occurring headers into single headers." + ;; TODO: Implement properly and tune. Since duplicated headers + ;; occur rarely in practice (only allowable on list headers), this + ;; should execute quickly and without consing for non-duplicate + ;; headers, and work reasonably for merging duplicates. + header-alist) + +(defmacro process-http-headers ((header value) headers &body clauses) + "Process the headers a-list produced by the `headers' form, as +specified by the clauses, and return as values the list of processed +headers and the rest a-list of unprocessed headers. + +The clauses are of the form ((string key) . body). For each header in +the a-list, if a clause with a matching (string-equal) string form, +which is evaluated, is found, then body is evaluated in an environment +where the variables named via `header' and `value' are bound to the +relevant header and value strings, and the result of evaluating key +and the implicit progn `body' are appended to the list of processed +headers. An empty body will evaluate to the value of `value'. + +If no matching clause is found, then a cons of header and value string +is appended to the list of unprocessed headers." + + (let ((processed (gensym)) + (remaining (gensym)) + (cond-clauses + (loop for (clause . body) in (mapcar #'(lambda (x) + (if (consp x) + x + (cons x nil))) + clauses) + for string = (string (if (consp clause) (car clause) clause)) + for key = (if (and (consp clause) (cadr clause)) + (cadr clause) + (intern (string-upcase string) "KEYWORD")) + collect `((string-equal ,header ,string) + (list ,key (progn ,value ,@body)))))) + `(loop for (,header . ,value) in ,headers + if (cond ,@cond-clauses) nconc it into ,processed + else collect (cons ,header ,value) into ,remaining + finally (return (values ,processed ,remaining))))) + +(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 (header-exists-p ,obj-sym (quote ,slot)) + (with-headers ((,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)))) + ;;;; 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) @@ -166,11 +265,116 @@ validate the whole request, including method and url.")) (http-message-version request)))) t) -(defclass response/0.9 (response) - ((entity :initarg :entity :reader http-message-entity))) +(defmethod request-entity ((request request/0.9)) + nil) -(defmethod get-response-class ((version (eql (get-http-version 0 9)))) - (find-class 'response/0.9)) +(defclass response/0.9 (response) + ((version :allocation :class :initform (get-http-version 0 9) + :reader http-message-version) + (entity :initarg :entity :reader http-message-entity))) + +(defmethod initialize-instance :after + ((instance response/0.9) &rest initargs &allow-other-keys) + t) (defmethod render-http-message ((message response/0.9) stream) (render-entity-body (http-message-entity message) stream)) + +;;;; HTTP/1.0 + +(defclass request/1.0 (request) + ((version :allocation :class :initform (get-http-version 1 0) + :reader http-message-version) + (authorization :initarg :authorization :reader request-authorization) + (cookie :initarg :cookie :reader request-cookie) + (date :initarg :date :reader request-date) + (from :initarg :from :reader request-from) + (if-modified-since :initarg :if-modified-since + :reader request-if-modified-since) + (pragma :initarg :pragma :reader request-pragma) + (referer :initarg :referer :reader request-referer) + (user-agent :initarg :user-agent :reader request-user-agent) + (entity) + (entity-headers :initarg :entity-headers + :initform nil))) + +(defmethod shared-initialize :after + ((instance request/1.0) slots &rest args &key host) + (declare (ignore slots args)) + (when host + (setf (slot-value instance 'url) + (merge-urls (slot-value instance 'url) host)))) + +(defgeneric compute-request-initargs (request headers) + (:documentation + "Given a parsed HTTP header-list, compute the initargs that will be +used to call `reinitialize-instance'.")) + +(defmethod compute-request-initargs ((request request/1.0) headers) + (multiple-value-bind (initargs rest) + (process-http-headers (h v) headers + :authorization + :date + :from + :if-modified-since + :pragma + (:referer (parse-url-from-string v)) + :user-agent + (:cookie (parse-key-value-list v :list-delimiter #\;)) + (:host (parse-url-from-string (concatenate 'string "http://" v)))) + (list* :entity-headers rest initargs))) + +(defmethod parse-request-remainder ((request request/1.0) stream) + (let* ((headers (parse-http-headers stream)) + (initargs (compute-request-initargs request headers))) + (apply #'reinitialize-instance request initargs) + t)) + +(defmethod request-entity ((request request/1.0)) + (if (slot-boundp request 'entity) + (slot-value request 'entity) + (setf (slot-value request 'entity) + (read-request-entity request)))) + +(defmethod read-request-entity ((request request/1.0)) + (let* ((headers (slot-value request 'entity-headers)) + (length-cons (assoc "content-length" headers :test #'string-equal)) + (length (and length-cons (parse-integer (cdr length-cons)))) + (stream (request-stream request))) + (when length + (let ((buffer (make-string length))) + (read-sequence buffer stream) + (make-instance 'string-entity :content-length length + :content-type (cdr (assoc "content-type" headers + :test #'string-equal)) + :body buffer))))) + +(defclass response/1.0 (response) + ((version :allocation :class :initform (get-http-version 1 0) + :reader http-message-version) + (date :initarg :date :reader response-date) + (location :initarg :location :reader response-location) + (pragma :initarg :pragma :reader response-pragma) + (set-cookie :initarg :set-cookie :reader response-set-cookie) + (entity :initarg :entity :reader http-message-entity))) + +(defmethod render-http-message ((message response/1.0) stream) + (format stream "~A ~D ~A" (http-message-version message) + (response-status-code message) + (HTTP-Code-Description (response-status-code message))) + (http-terpri stream) + (render-slots (message stream) + (date "Date" + (format stream "~A" date)) + (location "Location" + (format stream "~A" location)) + (pragma "Pragma" + (format stream "~{~A~^, ~:}" pragma)) + (set-cookie "Set-Cookie" + (format stream "~:{~A~@[=~A~]~^;~:}" set-cookie))) + (when (slot-boundp message 'entity) + (render-entity-headers (http-message-entity message) stream) + (http-terpri stream) + (unless (and (response-request message) + (eq (request-method (response-request message)) :HEAD)) + (render-entity-body (http-message-entity message) stream))))