diff --git a/src/main/parsing.cl b/src/main/parsing.cl index 8c512e0..d5ec040 100644 --- a/src/main/parsing.cl +++ b/src/main/parsing.cl @@ -14,27 +14,193 @@ ;;;; with HTTP component constructs, based on the HTTP grammar. ;;;; -(defconstant +HTTP-LWS-CHARACTER-BAG+ '(#\Space #\Tab) +(defconstant +HTTP-LWS-Character-Bag+ '(#\Space #\Tab) "HTTP LWS characters.") +(defconstant +HTTP-Quote-Character+ #\" + "HTTP quote character.") + +(defconstant +HTTP-Default-List-Delimiter+ #\, + "HTTP default list delimiter character.") + +(defconstant +HTTP-Pair-Delimiter+ #\= + "HTTP key-value pair delimiter character.") + +(defun char-lws-p (char) + (declare (type character char)) + (member char +HTTP-LWS-Character-Bag+ :test #'char=)) + +(define-compiler-macro char-lws-p (char) + (let ((char-var (gensym))) + `(let ((,char-var ,char)) + (declare (type character ,char-var)) + (or ,@(loop for lws-char in +HTTP-LWS-Character-Bag+ + collect `(char= ,char-var ,lws-char)))))) + +(declaim (inline char-quote-p)) +(defun char-quote-p (char) + (declare (type character char)) + (char= char +HTTP-Quote-Character+)) + (defun string-trim-lws (string) "Trim HTTP LWS from string." - (string-trim +HTTP-LWS-CHARACTER-BAG+ string)) + (string-trim +HTTP-LWS-Character-Bag+ string)) -(defun parse-simple-list (string &key (list-delimiter #\,)) +(defun dequote-string (string) + "Dequote an HTTP string." + (delete +HTTP-Quote-Character+ string)) + +(defun parse-http-list (string &key (delimiter +HTTP-Default-List-Delimiter+)) + (declare (type string string) (character delimiter)) + (loop with state = :seek-element + with start = nil + with stop = nil + for char across string + for pos from 0 + when + (case state + (:seek-element + (cond + ((char-lws-p char) + nil) + ((char= char delimiter) + nil) + ((char-quote-p char) + (setq start pos + state :in-quoted-string) + nil) + (t + (setq start pos + state :in-token) + nil))) + (:in-token + (cond + ((char-lws-p char) + (setq stop pos + state :seek-delimiter) + t) + ((char-quote-p char) + (setq state :in-quoted-string) + nil) + ((char= char delimiter) + (setq stop pos + state :seek-element) + t) + (t + nil))) + (:in-quoted-string + (when (char-quote-p char) + (setq state :in-token)) + nil) + (:seek-delimiter + (cond + ((char= char delimiter) + (setq state :seek-element) + nil) + ((char-lws-p char) + nil) + (t + (error 'clash-syntax-error :fragment string + :reason "Whitespace in token"))))) + collect (subseq string start stop) + when + (and + (= pos (1- (length string))) + (case state + (:in-token + (setq stop nil) + t) + (:in-quoted-string + (error 'clash-syntax-error :fragment string + :reason "End of line in quoted-string")) + ((:seek-element :seek-delimiter) + nil))) + collect (subseq string start stop))) + +(defun parse-simple-list (string &key + (delimiter +HTTP-Default-List-Delimiter+)) "Parse a simple HTTP list from the string, returning a list of strings." - (mapcar #'string-trim-lws - (partition list-delimiter string :remove-empty-subseqs t))) + (mapcar #'(lambda (entry) (dequote-string (string-trim-lws entry))) + (parse-http-list string :delimiter delimiter))) + +(defun parse-key-value-pair (string &key (delimiter +HTTP-Pair-Delimiter+)) + (declare (type character delimiter)) + (or + (loop with in-quote = nil + for char across string + for pos from 0 + do + (cond + ((and in-quote (char-quote-p char)) + (setq in-quote nil)) + ((char-quote-p char) + (setq in-quote t)) + ((char= char delimiter) + (return (cons (dequote-string (subseq string 0 pos)) + (dequote-string (subseq string (1+ pos)))))) + (t + nil))) + (error 'clash-syntax-error :fragment string + :reason (format nil "Missing ~A in key-value pair." delimiter)))) (defun parse-key-value-list - (string &key (list-delimiter #\,) (pair-delimiter #\=)) + (string &key (list-delimiter +HTTP-Default-List-Delimiter+) + (pair-delimiter +HTTP-Pair-Delimiter+)) "Parse a list of key-value pairs from the string, returning an alist." (mapcar #'(lambda (elem) - (let* ((pos (position pair-delimiter elem)) - (key (subseq elem 0 pos)) - (value (subseq elem (1+ pos)))) - (cons key value))) - (parse-simple-list string :list-delimiter list-delimiter))) + (parse-key-value-pair elem :delimiter pair-delimiter)) + (parse-http-list string :delimiter list-delimiter))) + +(defconstant +Base64-Code-Array+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") + +(defun decode-base64-string (string &key (start 0) end) + (declare (fixnum start) (string string)) + (let ((end (or end (length string)))) + (declare (fixnum end)) + (with-output-to-string (stream) + (loop with count = 4 + with accumulator = 0 + with padding = 0 + for pos from start below end + for char = (char string pos) + for value = (position char +Base64-Code-Array+ :test #'char=) + do + (when (and (null value) (char= char #\=)) + (setq value 0) + (incf padding)) + (when value + (decf count) + (setf (ldb (byte 6 (* count 6)) accumulator) value)) + (when (zerop count) + (loop for byte from 2 downto padding + for item-value = (ldb (byte 8 (* byte 8)) accumulator) + for item-char = (code-char item-value) + do + (write-char item-char stream)) + (setq accumulator 0 count 4 padding 0)) + finally + (when (/= count 4) + (error 'clash-syntax-error :fragment string + :reason + "Base64-Encoding ended on non-block-boundary")))))) + +(defun parse-authority-string (string) + (let* ((scheme-end (position #\Space string)) + (scheme (subseq string 0 scheme-end))) + (cond + ((string-equal scheme "Basic") + (let* ((userid-password + (decode-base64-string string :start (1+ scheme-end))) + (userid-end (position #\: userid-password)) + (userid (subseq userid-password 0 userid-end)) + (password (subseq userid-password (1+ userid-end)))) + (list scheme + (cons "userid" userid) + (cons "password" password)))) + (t + (list* scheme + (parse-key-value-list (subseq string scheme-end))))))) (defun rfc1123-format-time (universal-time) (multiple-value-bind (second minute hour date month year day daylight-p zone)