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:
2000-07-22 00:18:59 +00:00
parent f30daaf80f
commit 22b2bf1abd

64
src/main/parsing.cl Normal file
View 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))))