source: project/release/4/intarweb/trunk/intarweb.scm @ 11592

Last change on this file since 11592 was 11592, checked in by sjamaan, 12 years ago

Rename set-header-contents! to update-header-contents! and create a nondestructive variant of it too
Fix definitions for a few header parsers

File size: 11.2 KB
Line 
1;;
2;; Intarweb is an improved HTTP library for Chicken
3;;
4; Copyright (c) 2008, Peter Bex
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11; 1. Redistributions of source code must retain the above copyright
12;    notice, this list of conditions and the following disclaimer.
13; 2. Redistributions in binary form must reproduce the above copyright
14;    notice, this list of conditions and the following disclaimer in the
15;    documentation and/or other materials provided with the distribution.
16; 3. Neither the name of the author nor the names of its
17;    contributors may be used to endorse or promote products derived
18;    from this software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
25; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
26; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
29; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
31; OF THE POSSIBILITY OF SUCH DAMAGE.
32;
33; Please report bugs, suggestions and ideas to the Chicken Trac
34; ticket tracking system (assign tickets to user 'sjamaan'):
35; http://trac.callcc.org
36
37(require-library srfi-1 srfi-13 regex regex-case base64)
38
39(module intarweb
40  (read-line-limit update-header-contents update-header-contents!
41   append-header-contents append-header-contents!
42   string->header-name header-name->string header-name=?
43   header-parsers get-header-contents
44   http-0.9-request-parser http-1.x-request-parser
45   make-request request? request-major-version request-minor-version
46   request-method request-uri request-headers request-port
47   protocol-parsers read-request write-request read-headers
48   make-response response? response-major-version response-minor-version
49   response-code response-reason response-headers response-port
50   header-unparsers write-response read-response
51
52   ;; http-header-parsers
53   split-multi-header unknown-header-parser single multiple
54   read-token get-quality get-param get-value get-values header-list-ref
55   natnum-parser symbol-parser-ci symbol-parser
56   make-value+params value+params? value+params-value value+params-params
57   default-header-unparser
58   )
59
60  (import scheme chicken (except extras read-token) ports data-structures
61          srfi-1 srfi-13 srfi-14 regex regex-case (prefix base64 base64:))
62
63(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
64
65(define (update-header-contents name contents headers)
66  (let loop ((h headers))
67    (cond
68     ((null? h) (cons (cons name contents) headers))
69     ((header-name=? name (caar h))
70      (set-cdr! (car h) contents)
71      headers)
72     (else (loop (cdr h))))))
73
74(define (update-header-contents! name contents headers)
75  (let loop ((h headers))
76    (cond
77     ((null? h) (cons (cons name contents) headers))
78     ((header-name=? name (caar h))
79      (cons (cons (caar h) contents) (cdr h)))
80     (else (cons (car h) (loop (cdr h)))))))
81
82(define (make-appender updater)
83  (lambda (name contents headers)
84    (let ((old (get-header-contents name headers)))
85      (if old
86          (updater name (append old contents) headers)
87          (updater name contents headers)))))
88
89(define append-header-contents  (make-appender update-header-contents))
90(define append-header-contents! (make-appender update-header-contents!))
91
92(define (string->header-name s) (string->symbol (string-downcase! s)))
93(define (header-name->string h) (symbol->string h))
94(define header-name=? eq?)
95
96(include "../header-parsers")
97
98;; This includes parsers for all RFC-defined headers
99(define header-parsers
100  (make-parameter
101   `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
102     (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
103     (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
104     (accept-ranges . ,(single symbol-parser-ci))
105     (age . ,(single natnum-parser))
106     (allow . ,(multiple symbol-parser))
107     (authorization . ,(single symbol-parser-ci))
108     (cache-control . ,cache-control-parser)
109     (connection . ,(multiple symbol-parser-ci))
110     (content-encoding . ,(multiple symbol-parser-ci))
111     (content-language . ,(multiple symbol-parser-ci))
112     (content-length . ,(single natnum-parser))
113     (content-location . ,(single identity))
114     (content-md5 . ,(single md5-parser))
115     (content-range . ,(single range-parser))
116     (content-type . ,(single symbol-parser-ci))
117     (date . ,(single http-time-parser))
118     (etag . ,(single entity-tag-parser))
119     (expect . ,(single key/values))
120     (expires . ,(single rfc822-time-parser))
121     (from . ,(multiple mailbox-parser))
122     (host . ,(single identity))
123     (if-match . ,(multiple entity-tag-parser))
124     (if-modified-since . ,(single rfc822-time-parser))
125     (if-none-match . ,(multiple entity-tag-parser))
126     (if-range . ,(multiple if-range-parser))
127     (if-unmodified-since . ,(single rfc822-time-parser))
128     (last-modified . ,(single rfc822-time-parser))
129     (location . ,(single identity))
130     (max-forwards . ,natnum-parser)
131     (pragma . ,pragma-parser)
132     (proxy-authenticate . ,(multiple symbol-parser-ci))
133     (proxy-authorization . ,(single symbol-parser-ci))
134     (range . ,range-parser)
135     (referer . ,(single identity))
136     (retry-after . ,retry-after-parser)
137     (server . ,(single identity))
138     (te . ,te-parser)
139     (trailer . ,(multiple symbol-parser-ci))
140     (transfer-encoding . ,(single symbol-parser-ci))
141     (upgrade . ,(multiple append-header-contents!))
142     (user-agent . ,(single identity))
143     (vary . ,(multiple symbol-parser-ci))
144     (via . ,via-parser)
145     (warning . ,warning-parser)
146     (www-authenticate . ,(single symbol-parser-ci))
147     ;; RFC 2109
148     (set-cookie . ,set-cookie-parser)
149     (cookie . ,cookie-parser)
150     ;; RFC 2965?
151     )))
152
153(define (get-header-contents name headers)
154  (alist-ref name headers header-name=?))
155
156;; The parser is supposed to return the new (possibly modified) headers list
157(define (parse-header name contents headers)
158  (let* ((default unknown-header-parser)
159         (parser (alist-ref name (header-parsers) header-name=? default)))
160    (parser name contents headers)))
161
162(define (parse-header-line line headers)
163  (or
164   (and-let* ((colon-idx   (string-index line #\:))
165              (header-name (string->header-name (string-take line colon-idx)))
166              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
167             (parse-header header-name contents headers))
168   (signal-http-condition "Bad header line" 'header-error 'contents line)))
169
170(define (read-headers port)
171  (let ((first-line (read-line port)))
172    (if (or (eof-object? first-line) (string-null? first-line))
173        '()
174        (let loop ((prev-line first-line)
175                   (line      (read-line port))
176                   (headers   '()))
177          (if (or (eof-object? line) (string-null? line))
178              (if (string-null? prev-line)
179                  headers
180                  (parse-header-line prev-line headers))
181              (if (char-whitespace? (string-ref line 0)) ; Continuation char?
182                  (loop (string-append prev-line line) (read-line port)
183                        headers)
184                  (loop line (read-line port)
185                        (parse-header-line prev-line headers))))))))
186
187(define (signal-http-condition msg type . more-info)
188  (signal (make-composite-condition
189           (make-property-condition 'http)
190           (apply make-property-condition type more-info)
191           (make-property-condition 'exn 'message msg))))
192
193(define-record request method uri major-version minor-version headers port)
194
195;; Perhaps we should have header parsers indexed by version or
196;; something like that, so you can define the maximum version. Useful
197;; for when expecting a response. Then we group request/response parsers
198;; together, as with request/response unparsers.
199(define (http-0.9-request-parser line in)
200  (regex-case line
201    ("[Gg][Ee][Tt] +([^ \t]+)"
202     (_ uri)
203     (make-request 'GET uri 0 9 '() in))
204    (else #f)))
205
206(define string->http-method string->symbol)
207(define http-method->string symbol->string)
208
209(define (http-1.x-request-parser line in)
210  (regex-case line
211   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
212    (_ method uri major minor)
213    (make-request (string->http-method method)
214                  uri (string->number major) (string->number minor)
215                  (read-headers in) in))
216   (else #f)))
217
218(define protocol-parsers   ; order matters here
219  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
220
221(define (read-request inport)
222  (let ((line (read-line inport (read-line-limit))))
223    ; Try each parser in turn to process the request-line.
224    ; A parser returns either #f or a request object
225    (let loop ((parsers (protocol-parsers)))
226      (if (null? parsers)
227          (signal-http-condition "Unknown protocol" 'unknown-protocol)
228          (or ((car parsers) line inport) (loop (cdr parsers)))))))
229
230;; TODO: Handle HTTP/0.9
231(define (write-request request)
232  (let ((o (request-port request)))
233    (fprintf o "~A ~A HTTP/~A.~A\r\n"
234             (request-method request)
235             (request-uri request)
236             (request-major-version request)
237             (request-minor-version request))
238    (for-each
239     (lambda (h)
240       (let* ((name (car h))
241              (contents (cdr h))
242              (def default-header-unparser)
243              (unparser (alist-ref name (header-unparsers) header-name=? def)))
244         (display (unparser name contents) o)))
245     (request-headers request))
246    (fprintf o "\r\n")))
247
248(define-record response code reason major-version minor-version headers port)
249
250(define header-unparsers
251  (make-parameter
252   `()))
253
254;; TODO: Handle HTTP/0.9
255(define (write-response response)
256  (let ((o (response-port response)))
257    (fprintf o "HTTP/~A.~A ~A ~A\r\n"
258             (response-major-version response)
259             (response-minor-version response)
260             (response-code response)
261             (response-reason response))
262    (for-each
263     (lambda (h)
264       (let* ((name (car h))
265              (contents (cdr h))
266              (def default-header-unparser)
267              (unparser (alist-ref name (header-unparsers) header-name=? def)))
268         (display (unparser name contents) o)))
269     (response-headers response))
270    (fprintf o "\r\n")))
271
272(define (http-1.x-response-parser line in)
273  (regex-case line
274   ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) ([0-9]{3}) +(.*)"
275    (_ major minor code reason)
276    (make-response (string->number code) reason
277                   (string->number major) (string->number minor)
278                   (read-headers in) in))
279   (else #f)))
280
281;; TODO: Handle HTTP/0.9
282(define (read-response inport)
283  (let* ((line (read-line inport (read-line-limit))))
284    (http-1.x-response-parser line inport)))
285
286)
Note: See TracBrowser for help on using the repository browser.