Extensive rewrite of parsing routines, most parsable headers in
requests and entities are now parsed. Furthermore the whole request-entity handling has been changed to allow lazy parsing, parsed entity headers, and flexible choice of entities. This is all to support the handling of MIME multipart entities, especially multipart/form-data. The current revision is a first cut, and some further rewrites are needed.
This commit is contained in:
@ -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"
|
||||
|
||||
@ -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))))
|
||||
|
||||
@ -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))))
|
||||
|
||||
@ -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)))
|
||||
|
||||
294
src/main/mime.cl
Normal file
294
src/main/mime.cl
Normal file
@ -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))))))))))))
|
||||
@ -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."
|
||||
|
||||
@ -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)
|
||||
(unless (member method allowed-methods)
|
||||
(error 'clash-error :code +HTTP-Code-Method-Not-Allowed+
|
||||
:entity-initargs (list :allow allowed-methods)))))
|
||||
: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)
|
||||
|
||||
@ -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
|
||||
|
||||
Reference in New Issue
Block a user