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

Last change on this file since 11732 was 11732, checked in by sjamaan, 13 years ago

Make parsers/unparsers list complete and rearrange some code

File size: 15.3 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 defstruct)
38
39(module intarweb
40  (read-line-limit replace-header-contents replace-header-contents!
41   update-header-contents update-header-contents! make-headers single-headers
42   string->header-name header-name->string
43   header-parsers header-unparsers unparse-headers
44   http-0.9-request-parser http-1.x-request-parser
45   http-0.9-request-unparser http-1.x-request-unparser
46   
47   make-request request? request-major-version request-minor-version
48   request-method request-uri request-headers request-port request-copy
49   
50   request-parsers read-request request-unparsers write-request read-headers
51   make-response response? response-major-version response-minor-version
52   response-code response-reason response-headers response-port response-copy
53   write-response response-parsers read-response
54
55   ;; http-header-parsers
56   split-multi-header unknown-header-parser single multiple read-token
57   get-header-contents get-header-values
58   get-quality get-value get-params get-param header-list-ref
59   natnum-parser symbol-parser-ci symbol-parser
60   default-header-unparser
61   )
62
63  (import scheme chicken (except extras read-token) ports data-structures
64          srfi-1 srfi-13 srfi-14 regex regex-case (prefix base64 base64:)
65          defstruct)
66
67(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
68
69(define (replace-header-contents! name contents headers)
70  (let loop ((h headers))
71    (cond
72     ((null? h) (cons (cons name contents) headers))
73     ((eq? name (caar h))
74      (set-cdr! (car h) contents)
75      headers)
76     (else (loop (cdr h))))))
77
78(define (replace-header-contents name contents headers)
79  (let loop ((h headers))
80    (cond
81     ((null? h) (cons (cons name contents) headers))
82     ((eq? name (caar h))
83      (cons (cons (caar h) contents) (cdr h)))
84     (else (cons (car h) (loop (cdr h)))))))
85
86(define (make-updater replacer)
87  (lambda (name contents headers)
88    (let ((old (get-header-contents name headers '())))
89      (replacer name
90                (if (member name (single-headers))
91                    (list (last contents))
92                    (append old contents))
93                headers))))
94
95(define update-header-contents  (make-updater replace-header-contents))
96(define update-header-contents! (make-updater replace-header-contents!))
97
98(define (string->header-name s) (string->symbol (string-downcase! s)))
99(define (header-name->string h) (string-titlecase (symbol->string h)))
100
101;; Make a header set from a literal expression by folding in the headers
102;; with any previous ones
103(define (make-headers headers-to-be #!optional (old-headers '()))
104  (fold (lambda (h new-headers)
105          (update-header-contents
106           (car h)
107           (map (lambda (v)
108                  (if (vector? v) v (vector v '()))) ; normalize to vector
109                (cdr h))
110           new-headers))
111        old-headers
112        headers-to-be))
113
114(include "../header-parsers") ; Also includes header unparsers
115
116;; Any unknown headers are considered to be multi-headers, always
117(define single-headers
118  (make-parameter '(accept-ranges age authorization content-length
119                    content-location content-md5 content-type date etag
120                    expect expires host if-modified-since if-unmodified-since
121                    last-modified location max-forwards proxy-authorization
122                    range referer retry-after server transfer-encoding
123                    user-agent www-authenticate)))
124
125(define string->http-method string->symbol)
126(define http-method->string symbol->string)
127
128;;;;;;;;;;;;;;;;;;;;;;;;;
129;;;; Request parsing ;;;;
130;;;;;;;;;;;;;;;;;;;;;;;;;
131
132;; This includes parsers for all RFC-defined headers
133(define header-parsers
134  (make-parameter
135   `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
136     (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
137     (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
138     (accept-ranges . ,(single symbol-parser-ci))
139     (age . ,(single natnum-parser))
140     (allow . ,(multiple symbol-parser))
141     (authorization . ,(single symbol-parser-ci))
142     (cache-control . ,cache-control-parser)
143     (connection . ,(multiple symbol-parser-ci))
144     (content-encoding . ,(multiple symbol-parser-ci))
145     (content-language . ,(multiple symbol-parser-ci))
146     (content-length . ,(single natnum-parser))
147     (content-location . ,(single identity))
148     (content-md5 . ,(single md5-parser))
149     (content-range . ,(single range-parser))
150     (content-type . ,(single symbol-parser-ci))
151     (date . ,(single http-time-parser))
152     (etag . ,(single entity-tag-parser))
153     (expect . ,(single key/values))
154     (expires . ,(single rfc822-time-parser))
155     (from . ,(multiple mailbox-parser))
156     (host . ,(single identity))
157     (if-match . ,(multiple entity-tag-parser))
158     (if-modified-since . ,(single rfc822-time-parser))
159     (if-none-match . ,(multiple entity-tag-parser))
160     (if-range . ,(multiple if-range-parser))
161     (if-unmodified-since . ,(single rfc822-time-parser))
162     (last-modified . ,(single rfc822-time-parser))
163     (location . ,(single identity))
164     (max-forwards . ,(single natnum-parser))
165     (pragma . ,pragma-parser)
166     (proxy-authenticate . ,(multiple symbol-parser-ci))
167     (proxy-authorization . ,(single symbol-parser-ci))
168     (range . ,range-parser)
169     (referer . ,(single identity))
170     (retry-after . ,retry-after-parser)
171     (server . ,(single identity))
172     (te . ,te-parser)
173     (trailer . ,(multiple symbol-parser-ci))
174     (transfer-encoding . ,(single symbol-parser-ci))
175     (upgrade . ,(multiple update-header-contents!))
176     (user-agent . ,(single identity))
177     (vary . ,(multiple symbol-parser-ci))
178     (via . ,via-parser)
179     (warning . ,warning-parser)
180     (www-authenticate . ,(single symbol-parser-ci))
181     ;; RFC 2109
182     (set-cookie . ,set-cookie-parser)
183     (cookie . ,cookie-parser)
184     ;; RFC 2965?
185     )))
186
187;; The parser is supposed to return the new (possibly modified) headers list
188(define (parse-header name contents headers)
189  (let* ((default unknown-header-parser)
190         (parser (alist-ref name (header-parsers) eq? default)))
191    (parser name contents headers)))
192
193(define (parse-header-line line headers)
194  (or
195   (and-let* ((colon-idx   (string-index line #\:))
196              (header-name (string->header-name (string-take line colon-idx)))
197              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
198             (parse-header header-name contents headers))
199   (signal-http-condition "Bad header line" 'header-error 'contents line)))
200
201(define (read-headers port)
202  (let ((first-line (read-line port)))
203    (if (or (eof-object? first-line) (string-null? first-line))
204        '()
205        (let loop ((prev-line first-line)
206                   (line      (read-line port))
207                   (headers   '()))
208          (if (or (eof-object? line) (string-null? line))
209              (if (string-null? prev-line)
210                  headers
211                  (parse-header-line prev-line headers))
212              (if (char-whitespace? (string-ref line 0)) ; Continuation char?
213                  (loop (string-append prev-line line) (read-line port)
214                        headers)
215                  (loop line (read-line port)
216                        (parse-header-line prev-line headers))))))))
217
218(define (signal-http-condition msg type . more-info)
219  (signal (make-composite-condition
220           (make-property-condition 'http)
221           (apply make-property-condition type more-info)
222           (make-property-condition 'exn 'message msg))))
223
224(defstruct request method uri major-version minor-version (headers '()) port)
225
226;; Perhaps we should have header parsers indexed by version or
227;; something like that, so you can define the maximum version. Useful
228;; for when expecting a response. Then we group request/response parsers
229;; together, as with request/response unparsers.
230(define (http-0.9-request-parser line in)
231  (regex-case line
232    ("[Gg][Ee][Tt] +([^ \t]+)"
233     (_ uri)
234     (make-request method: 'GET uri: uri
235                   major-version: 0 minor-version: 9
236                   port: in))
237    (else #f)))
238
239;; XXX This actually parses anything >= HTTP/1.0
240(define (http-1.x-request-parser line in)
241  (regex-case line
242   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
243    (_ method uri major minor)
244    (make-request method: (string->http-method method) uri: uri
245                  major-version: (string->number major)
246                  minor-version: (string->number minor)
247                  headers: (read-headers in)
248     port: in))
249   (else #f)))
250
251(define request-parsers   ; order matters here
252  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
253
254(define (read-request inport)
255  (let* ((line (read-line inport (read-line-limit)))
256         ;; A bit ugly, but simpler than the alternatives
257         (line (if (eof-object? line) "" line)))
258    ;; Try each parser in turn to process the request-line.
259    ;; A parser returns either #f or a request object
260    (let loop ((parsers (request-parsers)))
261      (if (null? parsers)
262          (signal-http-condition "Unknown protocol" 'unknown-protocol)
263          (or ((car parsers) line inport) (loop (cdr parsers)))))))
264
265;;;;;;;;;;;;;;;;;;;;;;;;;;;
266;;;; Request unparsing ;;;;
267;;;;;;;;;;;;;;;;;;;;;;;;;;;
268
269(define header-unparsers
270  (make-parameter
271   `()))
272
273(define (unparse-headers headers out)
274  (for-each
275     (lambda (h)
276       (let* ((name (car h))
277              (contents (cdr h))
278              (def default-header-unparser)
279              (unparser (alist-ref name (header-unparsers) eq? def)))
280         (display (unparser name contents) out)))
281     headers))
282
283(define (write-request-line request)
284  (fprintf (request-port request)
285           "~A ~A HTTP/~A.~A\r\n"
286           (request-method request)
287           (request-uri request)
288           (request-major-version request)
289           (request-minor-version request)))
290
291(define (http-0.9-request-unparser request)
292  request) ;; The request-body will just follow
293
294;; XXX This actually unparses anything >= HTTP/1.0
295(define (http-1.x-request-unparser request)
296  (and-let* (((>= (request-major-version 1)))
297             (o (request-port request)))
298    (write-request-line request)
299    (unparse-headers (request-headers request) o)
300    (fprintf o "\r\n")
301    request))
302
303;; Do something with special headers
304
305(define request-unparsers  ; order matters here
306  (make-parameter (list http-1.x-request-unparser http-0.9-request-unparser)))
307
308(define (write-request request)
309  ;; Try each unparser in turn to write the request-line.
310  ;; An unparser returns either #f or a new request object.
311  (let loop ((unparsers (request-unparsers)))
312    (if (null? unparsers)
313        (signal-http-condition "Unknown protocol" 'unknown-protocol)
314        (or ((car unparsers) request) (loop (cdr unparsers))))))
315
316;;;;;;;;;;;;;;;;;;;;;;;;;;;;
317;;;; Response unparsing ;;;;
318;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319
320(defstruct response code reason major-version minor-version headers port)
321
322(define (http-0.9-response-unparser request response)
323  response) ;; The response-body will just follow
324
325(define (write-response-line request response)
326  (fprintf (response-port response)
327           "HTTP/~A.~A ~A ~A\r\n"
328           (response-major-version response)
329           (response-minor-version response)
330           (response-code response)
331           (response-reason response)))
332
333;; XXX This actually unparses anything >= HTTP/1.0
334(define (http-1.x-response-unparser request response)
335  (and-let* (((>= (response-major-version 1)))
336             (o (response-port response)))
337    (write-response-line request response)
338    (unparse-headers (response-headers response) o)
339    (fprintf o "\r\n")
340    response))
341
342(define response-unparsers
343  (make-parameter (list http-1.x-response-unparser http-0.9-response-unparser)))
344
345(define (write-response request response)
346  ;; Try each unparser in turn to write the response-line.
347  ;; An unparser returns either #f or a new response object.
348  (let loop ((unparsers (response-unparsers)))
349    (if (null? unparsers)
350        (signal-http-condition "Unknown protocol" 'unknown-protocol)
351        (or ((car unparsers) request response) (loop (cdr unparsers))))))
352
353;;;;;;;;;;;;;;;;;;;;;;;;;;
354;;;; Response parsing ;;;;
355;;;;;;;;;;;;;;;;;;;;;;;;;;
356
357(define (http-1.x-response-parser request line in)
358  (regex-case line
359   ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) ([0-9]{3}) +(.*)"
360    (_ major minor code reason)
361    (make-response code: (string->number code) reason: reason
362                   major-version: (string->number major)
363                   minor-version: (string->number minor)
364                   headers: (read-headers in)
365                   port: in))
366   (else #f)))
367
368(define response-parsers ;; order matters here
369  (make-parameter (list http-1.x-response-parser)))
370
371(define (read-response request inport)
372  ;; You can't "detect" a 0.9 response, because there is no response line.
373  ;; It will simply output the body directly, so we should not even attempt
374  ;; to read the line and do detection on it.
375  ;; This gives us one problem: what if we send a 1.x request and receive
376  ;; a 0.9 response? Nothing we can do against that right now.
377  (if (and (= (request-major-version request) 0)
378           (= (request-minor-version request) 9))
379      (make-response code: 200 reason: "OK"
380                     major-version: 0
381                     minor-version: 9
382                     port: inport)
383      (let* ((line (read-line inport (read-line-limit))))
384        (let loop ((parsers (response-parsers)))
385          (if (null? parsers)
386              (signal-http-condition "Unknown protocol" 'unknown-protocol)
387              (or ((car parsers) request line inport) (loop (cdr parsers))))))))
388
389)
Note: See TracBrowser for help on using the repository browser.