diff --git a/CLASH.system b/CLASH.system index f1ae2b0..8daf5d4 100644 --- a/CLASH.system +++ b/CLASH.system @@ -42,6 +42,8 @@ :depends-on ("conditions" "status-codes")) (:file "version" :depends-on ("conditions" "status-codes")) + (:file "mime" + :depends-on ("conditions" "parsing")) (:file "buffer" :depends-on ("conditions")) (:file "http-io" diff --git a/src/main/entity.cl b/src/main/entity.cl index 993bf49..7358046 100644 --- a/src/main/entity.cl +++ b/src/main/entity.cl @@ -16,12 +16,20 @@ (defclass entity () ()) +(defgeneric compute-entity-initargs (entity headers) + (:method-combination nconc) + (:documentation + "Given a parsed HTTP header-list, compute the initargs that will be +used to call `reinitialize-instance' on the entity.")) + (defgeneric render-entity-headers (entity stream)) (defgeneric render-entity-body (entity stream)) (defclass entity-header-mixin/1.1 () ((allow :initarg :allow :reader entity-allow) + (content-disposition :initarg :content-disposition + :reader entity-content-disposition) (content-encoding :initarg :content-encoding :reader entity-content-encoding) (content-language :initarg :content-language @@ -35,10 +43,27 @@ (expires :initarg :expires :reader entity-expires) (last-modified :initarg :last-modified :reader entity-last-modified))) +(defmethod compute-entity-initargs nconc + ((entity entity-header-mixin/1.1) headers) + (process-http-headers (h v) headers + (:allow (mapcar #'get-method-symbol (parse-simple-list v))) + (:content-disposition (parse-content-disposition-string v)) + (:content-encoding (parse-simple-list v)) + (:content-language (parse-simple-list v)) + (:content-length (parse-integer v)) + (:content-location (parse-url-from-string v)) + (:content-md5 (decode-base64-string v)) + :content-range + (:content-type (parse-content-type-string v)) + (:expires (parse-http-date v)) + (:last-modified (parse-http-date v)))) + (defmethod render-entity-headers ((e entity-header-mixin/1.1) stream) (render-slots (e stream) (allow "Allow" (write-http-element-list-1 allow stream)) + (content-disposition "Content-Disposition" + (render-content-disposition content-disposition stream)) (content-encoding "Content-Encoding" (write-http-element-list-1 content-encoding stream)) (content-language "Content-Language" @@ -46,15 +71,15 @@ (content-length "Content-Length" (format stream "~D" content-length)) (content-location "Content-Location" - (princ content-location stream)) - #+NIL + (write-string (url-string content-location) stream)) (content-md5 "Content-MD5" - (write-string (base64-encode-string content-md5) stream)) - #+NIL + (write-string (encode-base64-string content-md5) stream)) (content-range "Content-Range" (princ content-range stream)) (content-type "Content-Type" - (princ content-type stream)) + (if (stringp content-type) + (write-string content-type stream) + (render-content-type content-type stream))) (expires "Expires" (write-string (rfc1123-format-time expires) stream)) (last-modified "Last-Modified" @@ -105,13 +130,13 @@ (open (entity-pathname entity) :direction :input))))) (defclass cached-entity-mixin () - ((body-cache))) + ((rendered-body))) (defmethod render-entity-body :around ((entity cached-entity-mixin) stream) (prog1 nil - (if (slot-boundp entity 'body-cache) - (write-sequence (slot-value entity 'body-cache) stream) - (setf (slot-value entity 'body-cache) + (if (slot-boundp entity 'rendered-body) + (write-sequence (slot-value entity 'rendered-body) stream) + (setf (slot-value entity 'rendered-body) (with-output-to-string (cache-stream) (with-open-stream (combined-stream (make-broadcast-stream stream cache-stream)) @@ -120,3 +145,99 @@ (defclass cached-file-entity (cached-entity-mixin file-entity) ()) +;;; Lazy Entities + +(defclass lazy-entity (entity entity-header-mixin/1.1) + ((body-stream :initarg :body-stream :reader entity-body-stream) + (boundary :initarg :boundary :initform nil :reader lazy-entity-boundary) + (forced-p :initform nil :reader lazy-entity-forced-p) + (last-part-p :initform nil :reader lazy-entity-last-part-p) + (cached-body))) + +(defmethod lazy-entity-force ((entity lazy-entity)) + (unless (lazy-entity-forced-p entity) + (cond + ((lazy-entity-boundary entity) + (setf (slot-value entity 'last-part-p) + (multipart-skip-to-boundary (slot-value entity 'body-stream) + (lazy-entity-boundary entity)))) + ((slot-boundp entity 'content-length) + (with-io-buffer (buffer) + (loop with in-stream = (slot-value entity 'body-stream) + with length = (length buffer) + for rest = (entity-content-length entity) then (- rest read) + for size = (min length rest) + for read = (read-sequence buffer in-stream :end size) + until (zerop (- rest read))))) + (t + (with-io-buffer (buffer) + (loop with in-stream = (slot-value entity 'body-stream) + for length = (read-sequence buffer in-stream) + until (zerop length))))) + (setf (slot-value entity 'forced-p) t))) + +(defmethod lazy-entity-copy ((entity lazy-entity) stream) + (when (lazy-entity-forced-p entity) + (error 'simple-clash-error + :format-control "Trying to re-read forced lazy-entity ~S." + :format-arguments (list entity))) + (cond + ((lazy-entity-boundary entity) + (setf (slot-value entity 'last-part-p) + (multipart-copy-to-boundary stream + (slot-value entity 'body-stream) + (lazy-entity-boundary entity)))) + ((slot-boundp entity 'content-length) + (with-io-buffer (buffer) + (loop with in-stream = (slot-value entity 'body-stream) + with length = (length buffer) + for rest = (entity-content-length entity) then (- rest read) + for size = (min length rest) + for read = (read-sequence buffer in-stream :end size) + do + (write-sequence buffer stream :end read) + until (zerop (- rest read))))) + (t + (with-io-buffer (buffer) + (loop with in-stream = (slot-value entity 'body-stream) + for length = (read-sequence buffer in-stream) + until (zerop length) + do + (write-sequence buffer stream :end length))))) + (setf (slot-value entity 'forced-p) t)) + +(defmethod entity-body ((entity lazy-entity)) + (cond + ((slot-boundp entity 'cached-body) + (slot-value entity 'cached-body)) + (t + (setf (slot-value entity 'cached-body) + (with-output-to-string (stream) + (lazy-entity-copy entity stream)))))) + +(defun multipart-create-next-entity (stream class boundary) + (let* ((headers (parse-mime-headers stream)) + (entity (make-instance class :body-stream stream :boundary boundary))) + (apply #'reinitialize-instance entity + (compute-entity-initargs entity headers)))) + +(defun make-multipart-entity-iterator-fun (entity class) + (let ((boundary (mime-type-parameter (entity-content-type entity) :boundary)) + (stream (entity-body-stream entity)) + (last-entity nil)) + (lambda () + (if (and last-entity (lazy-entity-last-part-p last-entity)) + nil + (progn + (if (null last-entity) + (multipart-skip-to-boundary stream boundary) + (lazy-entity-force last-entity)) + (setq last-entity + (multipart-create-next-entity stream class boundary))))))) + +(defmacro with-multipart-entity-iterator + ((name entity &optional (class 'lazy-entity)) &body body) + (let ((iterator (gensym (symbol-name '#:with-multipart-entity-iterator-)))) + `(let ((,iterator (make-multipart-entity-iterator-fun ,entity ',class))) + (macrolet ((,name () '(funcall ,iterator))) + ,@body)))) diff --git a/src/main/messages.cl b/src/main/messages.cl index 12afda4..035f4f4 100644 --- a/src/main/messages.cl +++ b/src/main/messages.cl @@ -315,9 +315,9 @@ used to call `reinitialize-instance'.")) (multiple-value-bind (initargs rest) (process-http-headers (h v) headers (:authorization (parse-authority-string v)) - :date + (:date (parse-http-date v)) :from - :if-modified-since + (:if-modified-since (parse-http-date v)) :pragma (:referer (parse-url-from-string v)) :user-agent @@ -335,22 +335,20 @@ used to call `reinitialize-instance'.")) (if (slot-boundp request 'entity) (slot-value request 'entity) (setf (slot-value request 'entity) - (read-request-entity request)))) + (make-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 (connection-stream (request-connection request)))) - (when length - (let ((buffer (make-string length))) - (do ((start 0)) - ((>= (incf start (read-sequence buffer stream :start start)) - length))) - (make-instance 'string-entity :content-length length - :content-type (cdr (assoc "content-type" headers - :test #'string-equal)) - :body buffer))))) +(defgeneric get-request-entity-class (request)) +(defgeneric make-request-entity (request)) + +(defmethod make-request-entity ((request request/1.0)) + (let ((entity (make-instance (get-request-entity-class request))) + (headers (slot-value request 'entity-headers))) + (apply #'reinitialize-instance entity + :body-stream (connection-stream (request-connection request)) + (compute-entity-initargs entity headers)))) + +(defmethod get-request-entity-class ((request request/1.0)) + (find-class 'lazy-entity)) (defclass response/1.0 (response) ((version :allocation :class :initform (get-http-version 1 0) @@ -374,7 +372,7 @@ used to call `reinitialize-instance'.")) (pragma "Pragma" (format stream "~{~A~^, ~:}" pragma)) (location "Location" - (format stream "~A" location)) + (princ location stream)) (server "Server" (format stream "~{~A~^ ~}" (server-product-info server))) (www-authenticate "WWW-Authenticate" @@ -384,6 +382,7 @@ used to call `reinitialize-instance'.")) (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)) + (unless (or (= (response-status-code message) +HTTP-Code-Not-Modified+) + (and (response-request message) + (eq (request-method (response-request message)) :HEAD))) (render-entity-body (http-message-entity message) stream)))) diff --git a/src/main/method.cl b/src/main/method.cl index 56109f8..fbc3952 100644 --- a/src/main/method.cl +++ b/src/main/method.cl @@ -13,5 +13,13 @@ ;;;; ;;;; +(defconstant +maximum-safe-http-method-length+ 80 + "This defines the limit we impose on HTTP method names acceptable to +`get-method-symbol', in order to avoid interning huge stuff into the +keyword package, and thereby leaking non-negligible amounts of +memory.") + (defun get-method-symbol (method-string) + (when (> (length method-string) +maximum-safe-http-method-length+) + (error 'clash-error :code +http-code-bad-request+)) (intern method-string (symbol-package :initarg))) diff --git a/src/main/mime.cl b/src/main/mime.cl new file mode 100644 index 0000000..458146d --- /dev/null +++ b/src/main/mime.cl @@ -0,0 +1,294 @@ +;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; mime.cl --- MIME handling code +;;;; +;;;; Checkout Tag: $Name$ +;;;; $Id$ + +(in-package :CLASH) + +;;;; %File Description: +;;;; +;;;; This implements those parts of MIME that are necessary for +;;;; correct operation of HTTP processing. Those parts that are +;;;; implemented try to conform to RFC2045, RFC2046, RFC2047 (MIME +;;;; parts 1 to 3) and especially RFC2388 (multipart/form-data). +;;;; + +(define-condition mime-syntax-error (clash-syntax-error) + ()) + +(defconstant +maximum-safe-mime-token-length+ 80 + "This defines the limit we impose on MIME tokens acceptable to +`get-mime-symbol', in order to avoid interning huge stuff into the +keyword package, and thereby leaking non-negligible amounts of +memory.") + +(defun get-mime-symbol (string &optional (start 0) (end (length string))) + (when (null end) (setq end (length string))) + (when (> (- end start) +maximum-safe-mime-token-length+) + (error 'clash-error :code +http-code-bad-request+)) + (intern (nstring-upcase (subseq string start end)) + (symbol-package :initarg))) + +(defun render-mime-symbol (symbol stream) + (check-type symbol keyword) + (write-string (string-downcase (symbol-name symbol)) stream)) + +(defconstant +mime-type-separator+ #\/) +(defconstant +mime-parameter-separator+ #\;) +(defconstant +mime-value-separator+ #\=) +(defconstant +mime-quote-delimiter+ #\") +(defconstant +mime-quote-character+ #\\) +(defconstant +mime-specials-bag+ "()<>@,;:\\\"/[]?=") + +(defun dequote-mime-string (string &optional (start 0) (end (length string))) + (when (null end) (setq end (length string))) + (with-output-to-string (stream) + (do ((pos start (1+ pos))) + ((>= pos end)) + (if (char= (char string pos) +mime-quote-character+) + (write-char (char string (incf pos)) stream) + (write-char (char string pos) stream))))) + +(defun parse-mime-type-string + (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (let* ((type-end (or (position +mime-type-separator+ string + :start start :end end) + (skip-forward-to-lws string start end))) + (subtype-start (skip-forward-lws string (1+ type-end) end)) + (subtype-end (skip-forward-to-lws string subtype-start end))) + (values (with-lws-trimmed-bounds (string start type-end) + (get-mime-symbol string start type-end)) + (if (= subtype-start subtype-end) + nil + (with-lws-trimmed-bounds (string subtype-start subtype-end) + (get-mime-symbol string subtype-start subtype-end))))))) + +(defun render-mime-type-string (type subtype stream) + (write-string (string-downcase (symbol-name type)) stream) + (write-char +mime-type-separator+ stream) + (write-string (string-downcase (symbol-name subtype)) stream)) + +(defun parse-mime-parameters (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (when (= start end) + (return-from parse-mime-parameters nil)) + (do* ((parameters nil) + (start start)) + ((>= start end) + (return (nreverse parameters))) + (when (char/= (char string start) +mime-parameter-separator+) + (error 'mime-syntax-error :fragment string + :reason + "Invalid token while parsing MIME content-type parameters")) + (setq start (skip-forward-lws string (1+ start) end)) + (do ((pos start (1+ pos))) + ((or (>= pos end) + (char= (char string pos) +mime-parameter-separator+)) + (error 'mime-syntax-error + :fragment string + :reason "Invalid end of MIME content-type parameter")) + (let ((char (char string pos))) + (when (or (char-lws-p char) + (char= char +mime-value-separator+)) + (push (get-mime-symbol string start pos) parameters) + (setq start (skip-forward-lws string pos end)) + (when (or (>= start end) + (char/= (char string start) +mime-value-separator+)) + (error 'mime-syntax-error :fragment string + :reason "Invalid token in MIME content-type parameter")) + (setq start (skip-forward-lws string (1+ start) end)) + (when (>= start end) + (error 'mime-syntax-error :fragment string + :reason "Missing value in MIME content-type paramter")) + (return nil)))) + ;; Parse Value + (cond + ((char= (char string start) +mime-quote-delimiter+) + (incf start) + (do ((pos start (1+ pos))) + ((>= pos end) + (error 'mime-syntax-error :fragment string + :reason + "Premature end of quoted string in MIME parameter value")) + (when (and (char= (char string pos) +mime-quote-delimiter+) + (not (char= (char string (1- pos)) + +mime-quote-character+))) + (push (dequote-mime-string string start pos) parameters) + (setq start (skip-forward-lws string (1+ pos) end)) + (return nil)))) + (t + (do ((pos start (1+ pos))) + ((or (>= pos end) + (let ((char (char string pos))) + (or (char= char +mime-parameter-separator+) + (char-lws-p char)))) + (push (subseq string start pos) parameters) + (setq start (skip-forward-lws string pos end))))))))) + +(defun render-mime-parameters (parameters stream) + (loop for (key value) on parameters by #'cddr + do + (write-char +mime-parameter-separator+ stream) + (write-char #\Space stream) + (write-string (string-downcase (symbol-name key)) stream) + (write-char +mime-value-separator+ stream) + (write-char +mime-quote-delimiter+ stream) + (loop for char across value + do + (when (find char +mime-specials-bag+) + (write-char +mime-quote-character+ stream)) + (write-char char stream)) + (write-char +mime-quote-delimiter+ stream))) + +(defun parse-content-type-string (string) + (let ((parameter-start (position +mime-parameter-separator+ string))) + (multiple-value-bind (type subtype) + (parse-mime-type-string string 0 parameter-start) + (list* type subtype + (when parameter-start + (parse-mime-parameters string parameter-start)))))) + +(defun render-content-type (content-type stream) + (destructuring-bind (type subtype . parameters) content-type + (render-mime-type-string type subtype stream) + (render-mime-parameters parameters stream))) + +(defun parse-content-disposition-string (string) + (let ((parameter-start (position +mime-parameter-separator+ string)) + (start 0)) + (list* + (with-lws-trimmed-bounds (string start parameter-start) + (get-mime-symbol string start parameter-start)) + (when parameter-start + (parse-mime-parameters string parameter-start))))) + +(defun render-content-disposition (content-disposition stream) + (destructuring-bind (type . parameters) content-disposition + (render-mime-symbol type stream) + (render-mime-parameters parameters stream))) + +(defun parse-mime-headers (stream) + (parse-http-headers stream)) + +;; Accessors + +(defun mime-type-parameter (mime-type parameter) + (getf (cddr mime-type) parameter)) + +(defun (setf mime-type-parameter) (new-value mime-type parameter) + (setf (getf (cddr mime-type) parameter) new-value)) + +(defun mime-disposition-parameter (disposition parameter) + (getf (cdr disposition) parameter)) + +(defun (setf mime-disposition-parameter) (new-value disposition parameter) + (setf (getf (cdr disposition) parameter) new-value)) + +;; Multipart parsing + +(defun multipart-skip-to-boundary (stream boundary) + (do ((state :start-of-line) + (char (read-char stream) (read-char stream))) + (nil) + (case state + (:in-line + (case char + (#\Return + (setq state :got-cr)) + ;; Technically, this is illegal, but most implementations do + ;; recognize this, and so do we... + (#\Newline + (setq state :start-of-line)))) + (:got-cr + (if (char= char #\Newline) + (setq state :start-of-line) + (progn + (unread-char char stream) + (setq state :in-line)))) + (:start-of-line + (block test + (flet ((break-off () + (unread-char char stream) + (setq state :in-line) + (return-from test nil)) + (next-char () (setq char (read-char stream)))) + (when (char/= char #\-) + (break-off)) + (when (char/= (next-char) #\-) + (break-off)) + (dotimes (i (length boundary)) + (when (char/= (next-char) (char boundary i)) + (break-off)))) + ;; We've got a boundary, now test for last-p and skip lws/crlf + (return + (let ((last-p nil) + (char (read-char stream))) + (when (char= char #\-) + (setq char (read-char stream)) + (when (char= char #\-) + (setq last-p t char (read-char stream)))) + (loop + (when (char= char #\Newline) + (return last-p)) + (when (char= char #\Return) + (setq char (read-char stream))))))))))) + +(defun multipart-copy-to-boundary (out stream boundary) + (do ((state :start-of-line) + (char (read-char stream) (read-char stream))) + (nil) + (case state + (:in-line + (case char + (#\Return + (setq state :got-cr)) + ;; Technically, this is illegal, but most implementations do + ;; recognize this, and so do we... + (#\Newline + (setq state :start-of-line-lf)) + (t + (write-char char out)))) + (:got-cr + (if (char= char #\Newline) + (setq state :start-of-line-crlf) + (progn + (write-char #\Return out) + (unread-char char stream) + (setq state :in-line)))) + ((:start-of-line :start-of-line-lf :start-of-line-crlf) + (block test + (flet ((break-off (dash-count boundary-index) + (when (eq state :start-of-line-crlf) + (write-char #\Return out)) + (unless (eq state :start-of-line) + (write-char #\Newline out)) + (dotimes (i dash-count) (write-char #\- out)) + (write-sequence boundary out :end boundary-index) + (unread-char char stream) + (setq state :in-line) + (return-from test nil)) + (next-char () (setq char (read-char stream)))) + (when (char/= char #\-) + (break-off 0 0)) + (when (char/= (next-char) #\-) + (break-off 1 0)) + (dotimes (i (length boundary)) + (when (char/= (next-char) (char boundary i)) + (break-off 2 i))) + ;; We've got a boundary, now test for last-p and skip lws/crlf + (return + (let ((last-p nil) + (char (read-char stream))) + (when (char= char #\-) + (setq char (read-char stream)) + (when (char= char #\-) + (setq last-p t char (read-char stream)))) + (loop + (when (char= char #\Newline) + (return last-p)) + (when (char= char #\Return) + (setq char (read-char stream)))))))))))) diff --git a/src/main/parsing.cl b/src/main/parsing.cl index 22c9183..3a05bf2 100644 --- a/src/main/parsing.cl +++ b/src/main/parsing.cl @@ -50,6 +50,37 @@ "Trim HTTP LWS from string." (string-trim +HTTP-LWS-Character-Bag+ string)) +(declaim (inline skip-forward-lws)) +(defun skip-forward-lws (string start end) + (do ((pos start (1+ pos))) + ((or (>= pos end) (not (char-lws-p (char string pos)))) + pos))) + +(declaim (inline skip-backward-lws)) +(defun skip-backward-lws (string start end) + (do ((pos end (1- pos))) + ((or (<= pos start) (not (char-lws-p (char string pos)))) + pos))) + +(declaim (inline skip-forward-to-lws)) +(defun skip-forward-to-lws (string start end) + (do ((pos start (1+ pos))) + ((or (>= pos end) (char-lws-p (char string pos))) + pos))) + +(declaim (inline skip-backward-to-lws)) +(defun skip-backward-to-lws (string start end) + (do ((pos end (1- pos))) + ((or (<= pos start) (char-lws-p (char string pos))) + pos))) + +(defmacro with-lws-trimmed-bounds ((string-var start-var end-var) &body body) + `(let ((,end-var (or ,end-var (length ,string-var)))) + (let ((,start-var (skip-forward-lws ,string-var ,start-var ,end-var)) + (,end-var + (1+ (skip-backward-lws ,string-var ,start-var (1- ,end-var))))) + ,@body))) + (defun dequote-string (string) "Dequote an HTTP string." (delete +HTTP-Quote-Character+ string)) @@ -158,6 +189,8 @@ (defconstant +Base64-Code-Array+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") +(defconstant +Base64-Padding-Character+ #\=) + (defun decode-base64-string (string &key (start 0) end) (declare (fixnum start) (string string)) (let ((end (or end (length string)))) @@ -170,7 +203,7 @@ for char = (char string pos) for value = (position char +Base64-Code-Array+ :test #'char=) do - (when (and (null value) (char= char #\=)) + (when (and (null value) (char= char +Base64-Padding-Character+)) (setq value 0) (incf padding)) (when value @@ -189,6 +222,54 @@ :reason "Base64-Encoding ended on non-block-boundary")))))) +(defun encode-base64-string + (string &key (start 0) end use-crlf final-crlf (line-length 76)) + (declare (fixnum start) (string string)) + (let ((end (or end (length string)))) + (declare (fixnum end)) + (with-output-to-string (stream) + (loop with count = 3 + with accumulator = 0 + with line-count = 0 + for pos from start below end + for char = (char string pos) + for value = (char-code char) + do + ;; Snarf and stash byte + (decf count) + (setf (ldb (byte 8 (* count 8)) accumulator) value) + ;; If we've got 24 bits, then output encoded 4-tuple + (when (zerop count) + ;; Check line-length first + (when (> (+ line-count 4) line-length) + (when use-crlf (write-char #\Return stream)) + (write-char #\Newline stream) + (setq line-count 0)) + ;; Output 4-tuple + (loop for offset from 3 downto 0 + for index = (ldb (byte 6 (* offset 6)) accumulator) + do + (incf line-count) + (write-char (aref +Base64-Code-Array+ index) stream)) + ;; Reset stuff + (setq accumulator 0 count 3)) + finally + ;; If we didn't end on a 24 bit boundary, output rest with padding + (when (< count 3) + ;; Check line-length first + (when (> (+ line-count 4) line-length) + (when use-crlf (write-char #\Return stream)) + (write-char #\Newline stream)) + (loop for offset from 3 downto count + for index = (ldb (byte 6 (* offset 6)) accumulator) + do + (write-char (aref +Base64-Code-Array+ index) stream)) + (dotimes (i count) + (write-char +Base64-Padding-Character+ stream))) + (when final-crlf + (when use-crlf (write-char #\Return stream)) + (write-char #\Newline stream)))))) + (defun parse-authority-string (string) (let* ((scheme-end (position #\Space string)) (scheme (subseq string 0 scheme-end))) @@ -217,6 +298,163 @@ (format nil "~A, ~2,'0D ~A ~4,'0D ~2,'0D:~2,'0D:~2,'0D GMT" wkday date full-month year hour minute second)))) +(defun parse-http-time (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (unless (= 8 (- end start)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid length for http-time field (too short or too long)")) + (handler-case + (let ((hour (parse-integer string :start start :end (+ start 2))) + (min (parse-integer string :start (+ start 3) :end (+ start 5))) + (sec (parse-integer string :start (+ start 6) :end (+ start 8)))) + (assert (and (<= 0 hour 23) (<= 0 min 59) (<= 0 sec 59) + (char= (char string (+ start 2)) #\:) + (char= (char string (+ start 5)) #\:))) + (values hour min sec)) + (error () + (error 'clash-syntax-error :fragment (subseq string start end) + :readson "Invalid http-time"))))) + +(defun parse-http-day (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (unless (<= 1 (- end start) 2) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid length for day field (too short or too long)")) + (handler-case + (let ((day (parse-integer string :start start :end end))) + (assert (<= 1 day 31)) + day) + (error () + (error 'clash-syntax-error :fragment (subseq string start end) + :readson "Invalid http-date day"))))) + +(defconstant +http-date-month-names+ + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + +(defun lookup-month-by-name (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (unless (= 3 (- end start)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid length for month field (too short or too long)")) + (or + (loop for month-name in +http-date-month-names+ + for month from 1 + thereis (when (string= string month-name :start1 start :end1 end) + month)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason "Unknown month name in http-date")))) + +(defun parse-http-year (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (case (- end start) + (4 + (handler-case (parse-integer string :start start :end end) + (error () + (error 'clash-syntax-error :fragment (subseq string start end) + :readson "Invalid http-date year")))) + (2 + (handler-case + (let ((year (parse-integer string :start start :end end))) + (+ year (if (< year 50) + 2000 + 1900))) + (error () + (error 'clash-syntax-error :fragment (subseq string start end) + :readson "Invalid http-date year")))) + (t + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid length for year field (too short or too long)"))))) + +(defun parse-rfc1123-date (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (unless (= 29 (- end start)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid length for rfc1123-date (too short or too long)")) + (let ((day (parse-http-day string (+ start 5) (+ start 7))) + (month (lookup-month-by-name string (+ start 8) (+ start 11))) + (year (parse-http-year string (+ start 12) (+ start 16)))) + (multiple-value-bind (hour min sec) + (parse-http-time string (+ start 17) (+ start 25)) + (unless (string= string " GMT" :start1 (+ start 25) :end1 end) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid time-zone (must be GMT)")) + (let ((result (encode-universal-time sec min hour day month year 0))) + (multiple-value-bind (sec2 min2 hour2 day2 month2 year2) + (decode-universal-time result 0) + (unless (and (= sec sec2) (= min min2) (= hour hour2) + (= day day2) (= month month2) (= year year2)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Ambiguous rfc1123-date specification"))) + result))))) + +(defun parse-rfc850-date (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (let ((day-end (position #\, string :start start :end end))) + (unless (and day-end (= 24 (- end day-end)) + (<= 6 (- day-end start) 9)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid length for rfc850-date (too short or too long)")) + (let ((day (parse-http-day string (+ day-end 2) (+ day-end 4))) + (month (lookup-month-by-name string (+ day-end 5) (+ day-end 8))) + (year (parse-http-year string (+ day-end 9) (+ day-end 11)))) + (multiple-value-bind (hour min sec) + (parse-http-time string (+ day-end 12) (+ day-end 20)) + (unless (string= string " GMT" :start1 (+ day-end 20) :end1 end) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid time-zone (must be GMT)")) + (let ((result (encode-universal-time sec min hour day month year 0))) + (multiple-value-bind (sec2 min2 hour2 day2 month2 year2) + (decode-universal-time result 0) + (unless (and (= sec sec2) (= min min2) (= hour hour2) + (= day day2) (= month month2) (= year year2)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Ambiguous rfc850-date specification"))) + result)))))) + +(defun parse-asctime-date (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (unless (= 24 (- end start)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Invalid length for asctime-date (too short or too long)")) + (let ((day (parse-http-day string (+ start 8) (+ start 10))) + (month (lookup-month-by-name string (+ start 4) (+ start 7))) + (year (parse-http-year string (+ start 20) (+ start 24)))) + (multiple-value-bind (hour min sec) + (parse-http-time string (+ start 11) (+ start 19)) + (let ((result (encode-universal-time sec min hour day month year 0))) + (multiple-value-bind (sec2 min2 hour2 day2 month2 year2) + (decode-universal-time result 0) + (unless (and (= sec sec2) (= min min2) (= hour hour2) + (= day day2) (= month month2) (= year year2)) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason + "Ambiguous asctime-date specification"))) + result))))) + +(defun parse-http-date (string &optional (start 0) (end (length string))) + (with-lws-trimmed-bounds (string start end) + (unless (> (- end start) 3) + (error 'clash-syntax-error :fragment (subseq string start end) + :reason "Invalid length for HTTP-date (too short)")) + (case (char string (+ start 3)) ; see RFC for grammar + (#\, ; rfc1123-date + (parse-rfc1123-date string start end)) + (#\Space ; asctime-date + (parse-asctime-date string start end)) + (t ; Must be an rfc850-date + (parse-rfc850-date string start end))))) + (defun merge-multiple-keys (a-list &key (test #'eql)) "Merge multiple entries in an a-list into one entry which contains the list of values. All other entries are kept." diff --git a/src/main/resource.cl b/src/main/resource.cl index 38bdb3e..c03bdec 100644 --- a/src/main/resource.cl +++ b/src/main/resource.cl @@ -28,10 +28,22 @@ (defmethod access-resource ((resource resource) request) (let ((method (request-method request)) (allowed-methods (resource-allowed-methods resource))) - (if (member method allowed-methods) - (access-resource-using-method resource request method) - (error 'clash-error :code +HTTP-Code-Method-Not-Allowed+ - :entity-initargs (list :allow allowed-methods))))) + (unless (member method allowed-methods) + (error 'clash-error :code +HTTP-Code-Method-Not-Allowed+ + :entity-initargs (list :allow allowed-methods))) + (let ((response (access-resource-using-method resource request method))) + ;; Handle Conditional-Get as per RFC 1945 + (when (and (eq method :GET) + (header-exists-p request 'if-modified-since) + (= (response-status-code response) +HTTP-Code-Ok+) + (slot-boundp response 'entity) + (header-exists-p (http-message-entity response) + 'last-modified) + (<= (entity-last-modified (http-message-entity response)) + (request-if-modified-since request) + (get-universal-time))) + (setf (slot-value response 'status-code) +HTTP-Code-Not-Modified+)) + response))) (defclass static-resource (resource) ((entity :initarg :entity :accessor static-resource-entity) diff --git a/src/package.cl b/src/package.cl index dd7d74d..2e91d34 100644 --- a/src/package.cl +++ b/src/package.cl @@ -114,6 +114,10 @@ #:get-http-version #:parse-http-version #:format-http-version + ;; MIME + #:mime-syntax-error + #:mime-type-parameter + #:mime-disposition-parameter ;; Buffer #:*default-io-buffer-size* #:with-io-buffer @@ -177,6 +181,7 @@ #:render-entity-body #:entity-header-mixin/1.1 #:entity-allow + #:entity-content-disposition #:entity-content-encoding #:entity-content-language #:entity-content-length @@ -193,6 +198,10 @@ #:entity-body #:file-entity #:entity-pathname + #:lazy-entity + #:lazy-entity-force + #:lazy-entity-copy + #:with-multipart-entity-iterator ;; Resource #:resource #:resource-allowed-methods