Complete rewrite of nearly all list parsing routines. This handles

quoted-strings in both key and values of key value pairs and in simple
lists correctly.  Also factored out all magic constants, added some
stuff to make this halfway efficient (profiling to be done).  This
rewrite makes partition superfluous, maybe remove this from
src/utility.cl.

Added parsing of Base64 and authorization credentials.

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
+  (mapcar #'(lambda (entry) (dequote-string (string-trim-lws entry)))
-	  (partition list-delimiter string :remove-empty-subseqs t)))
+	  (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))
+	      (parse-key-value-pair elem :delimiter pair-delimiter))
-		     (key (subseq elem 0 pos))
+	  (parse-http-list string :delimiter list-delimiter)))
-		     (value (subseq elem (1+ pos))))
+
-		(cons key value)))
+(defconstant +Base64-Code-Array+
-	  (parse-simple-list string :list-delimiter list-delimiter)))
+  "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)