1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
(in-package :araneida)
(defvar *araneida-mode* :standard
"Defines what mode Araneida operates in. Controls things
such as how headers are handled.
:standard - default. Araneida-like operation
:tbnl - suitable for use as a TBNL frontend. TBNL will automatically put
Araneida into this mode on load.")
(defun read-http-line (stream &optional eof-error eof-value)
;; read a line terminated with a LF, even under old MacOS
(with-output-to-string (o)
(loop for char = (read-char stream eof-error eof-value)
while (and (not (eql char eof-value))
(not (eql char #.(code-char 10))))
do (write-char char o))))
(defun parse-protocol-version (string)
(let ((f (position #\/ string))
(d (position #\. string))
(l (length string)))
(+ (parse-integer string :start (1+ f) :end d)
(if d
(/ (parse-integer string :start (1+ d))
(expt 10 (- l d 1)))
0))))
(defun read-request-from-stream (listener stream)
(destructuring-bind (method url-string &optional protocol)
(split (read-http-line stream t) 3 '(#\Space))
(let ((headers (and protocol (read-headers stream))))
(ecase *araneida-mode*
(:standard
(let* ((http-version
(or (and protocol (parse-protocol-version protocol)) 0.9))
(content-length (parse-integer
(or (header-value :content-length headers) "0")))
(content-type (header-value :content-type headers))
(form-data-mime-type "multipart/form-data")
(form-data-p (and content-type
(>= (length content-type) (length form-data-mime-type))
(equal form-data-mime-type
(subseq (header-value :content-type headers)
0
(length form-data-mime-type)))))
(body (and (> content-length 0)
;; The make-array form sounds good but breaks on
;; streams (like Allegro's multivalent sockets)
;; that do not have some kind of character
;; element type, because parse-body (and other
;; code) assumes it gets a string, not a vector
;; of character codes. So I replaced it by
;; make-string (Arthur Lemmens). (merged by Alan Shields [14 November 2005])
;;
;; doesn't seem to break SBCL or CMUCL -- Alan Shields [14 November 2005]
(make-string content-length)))
(len (and (> content-length 0)
(read-sequence body stream)))
#+lispworks
(parsed-body (if (and body (not form-data-p))
(parse-body (map 'string
;; for some reason lispworks wants an array of code characters
;; according to Bob Hutchinson (hutch at recursive.ca)
;; -- Alan Shields [14 November 2005]
(lambda (c) (code-char c))
body)
body '(#\&) len)
nil))
#-lispworks
(parsed-body (if (and body (not form-data-p))
(parse-body body '(#\&) len)
nil))
(url (merge-url
;; it may be argued that we're going to hell for this, but
;; (header-value :host) may in fact be host:port and I'm
;; not about to pick it apart now just so we can use
;; make-url instead
(parse-urlstring
(format nil "http://~A/"
(or (header-value :host headers)
(http-listener-default-hostname listener))))
url-string)))
(make-instance 'request
:url url
:urlstring (urlstring url)
:method (intern (nstring-upcase method) 'keyword)
:http-version http-version
:body parsed-body
:unparsed-body body
:stream stream :headers headers )))
(:tbnl
(values method url-string protocol headers))))))
(defun parse-body (body-string &optional (delimiters '(#\&)) end)
"Parse BODY-STRING returning list of (var val) pairs"
(mapcar (lambda (x)
(mapcar #'urlstring-unescape (split-sequence #\= x :count 2)))
(split-sequence-if (lambda (x) (member x delimiters))
body-string :end end)))
(defun read-folded-line (stream &optional eof-error-p eof-value)
"Read a complete logical header line, including folded continuation lines."
(with-output-to-string (o)
(loop
(let* ((l (read-http-line stream eof-error-p eof-value))
(end (position-if (lambda (x) (or (eql x (code-char 10))
(eql x (code-char 13))))
l))
(next (and (if end (> end 0) t)
(> (length l) 0)
(peek-char nil stream nil nil))))
(write-sequence l o :end end)
(unless (or (eql next #\Space) (eql next #\Tab)) (return))))))
;;; Unless you're me (and probably not even then), you should be
;;; using REQUEST-HEADER not this:
(defun header-value (name header-list)
"Get the value of the header named NAME in HEADER-LIST"
(cadr (assoc name header-list)))
(defun read-headers (stream)
(let ((headers nil))
(do ((line (read-folded-line stream t) (read-folded-line stream t)))
((or (not line) (zerop (length line))) headers)
;; RFC 1945: "Each header field consists of a name followed
;; immediately by a colon (":"), a single space (SP) character,
;; and the field value. Field names are case- insensitive."
(let* ((colon-pos (position #\: line))
(keyword (subseq line 0 colon-pos))
(value (subseq line (+ 2 colon-pos)))
(keyword-symbol (intern (string-upcase keyword) :keyword))
(keyword-value (assoc keyword-symbol headers)))
(ecase *araneida-mode*
(:standard (if keyword-value
(setf (cdr (last keyword-value)) (list value))
(setf headers (acons keyword-symbol (list value) headers))))
(:tbnl (let ((name (if (stringp keyword)
keyword
(format nil "~a" keyword)))
(val (if (stringp value)
value
(format nil "~a" value))))
(if keyword-value
(rplacd (assoc name headers) val)
(push (cons name val) headers)))))))
headers))
|
