CLASH/src/main/parsing.cl

;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; parsing.cl --- General HTTP parsing routines
;;;; 
;;;; Checkout Tag: $Name$
;;;; $Id$

(in-package :CLASH)

;;;; %File Description:
;;;; 
;;;; This file implements various parsing routines useful in dealing
;;;; with HTTP component constructs, based on the HTTP grammar.
;;;; 

(eval-when (:compile-toplevel :load-toplevel :execute)
  
(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))

(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 #'(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 +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)
	      (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)
      (decode-universal-time universal-time 0)
    (declare (ignore daylight-p zone))
    (let ((wkday (aref #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") day))
	  (full-month (aref #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
			      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
			    (1- month))))
      (format nil "~A, ~2,'0D ~A ~4,'0D ~2,'0D:~2,'0D:~2,'0D GMT"
	      wkday date full-month year hour minute second))))

(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."
  (do* ((result nil)
	(rest a-list (rest rest))
	(key (caar rest) (caar rest))
	(entry (assoc key result :test test) (assoc key result :test test))
	(value (cdar rest) (cdar rest)))
       ((null rest) result)
    (if entry
	(setf (cdr entry)
	      (if (consp (cdr entry))
		  (cons value (cdr entry))
		  (list value (cdr entry))))
	(push (cons key value) result))))

;;; HTML escaping for error messages.

;;; This is especially important to avoid cross-scripting client
;;; attacks through our server.

(defun escape-text-for-html (text)
  (declare (type simple-string text))
  (with-output-to-string (stream)
    (loop for char of-type character across text
	  do
	  (case char
	    (#\< (write-string "&lt;" stream))
	    (#\> (write-string "&gt;" stream))
	    (#\& (write-string "&amp;" stream))
	    (#\" (write-string "&quot;" stream))
	    (t (write-char char stream))))))