Changes that bring CLASH up to extended HTTP/1.0 support:
Moved some of the common parsing and rendering subroutines to a new file. Many other functions should probably be moved over here, so watch this space as clean up progresses further.
This commit is contained in:
64
src/main/parsing.cl
Normal file
64
src/main/parsing.cl
Normal file
@ -0,0 +1,64 @@
|
|||||||
|
;;;; 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.
|
||||||
|
;;;;
|
||||||
|
|
||||||
|
(defconstant +HTTP-LWS-CHARACTER-BAG+ '(#\Space #\Tab)
|
||||||
|
"HTTP LWS characters.")
|
||||||
|
|
||||||
|
(defun string-trim-lws (string)
|
||||||
|
"Trim HTTP LWS from string."
|
||||||
|
(string-trim +HTTP-LWS-CHARACTER-BAG+ string))
|
||||||
|
|
||||||
|
(defun parse-simple-list (string &key (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)))
|
||||||
|
|
||||||
|
(defun parse-key-value-list
|
||||||
|
(string &key (list-delimiter #\,) (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)))
|
||||||
|
|
||||||
|
(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))))
|
||||||
Reference in New Issue
Block a user