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

Last change on this file since 12500 was 12500, checked in by sjamaan, 11 years ago

Add product unparser and fix product-parser to be as inconsistent as the HTTP spec

File size: 22.6 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(module intarweb
38  (read-line-limit replace-header-contents replace-header-contents!
39   update-header-contents update-header-contents! headers single-headers
40   headers->list string->header-name header-name->string
41   header-parsers header-unparsers unparse-header unparse-headers
42   http-0.9-request-parser http-1.x-request-parser
43   http-0.9-request-unparser http-1.x-request-unparser
44   
45   make-request request? request-major request-major-set!
46   request-minor request-minor-set!
47   request-method request-method-set! request-uri request-uri-set!
48   request-headers request-headers-set! request-port request-port-set!
49   update-request
50   
51   request-parsers read-request request-unparsers write-request read-headers
52   
53   make-response response? response-major response-major-set!
54   response-minor response-minor-set!
55   response-code response-code-set! response-reason response-reason-set!
56   response-headers response-headers-set! response-port response-port-set!
57   update-response
58   
59   write-response response-parsers read-response
60
61   ;; http-header-parsers
62   split-multi-header unknown-header-parser single multiple
63   parse-token parse-comment
64   header-contents header-values header-value header-list-ref
65   get-quality get-value get-params get-param
66   natnum-parser symbol-parser-ci symbol-parser product-parser
67   quote-string unparse-token default-header-unparser
68   entity-tag-unparser product-unparser
69   )
70
71  (import scheme chicken)
72 
73  (require-library srfi-1 srfi-13 regex regex-case base64 defstruct uri-generic)
74
75  (import extras ports data-structures
76          srfi-1 srfi-13 srfi-14 regex regex-case (prefix base64 base64:)
77          defstruct uri-generic)
78
79(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
80
81;; Make headers a new type, to force the use of the HEADERS procedure
82;; and ensure only proper header values are passed to all procedures
83;; that deal with headers.
84(define-record headers v)
85
86(define-record-printer (headers h out)
87  (fprintf out "#(headers: ~S)"
88           (headers-v h)))
89
90(define headers->list headers-v)
91
92;; XXX: Do we need these replace procedures in the exports list?  It
93;; looks like we can use update everywhere.  A remove-header could
94;; be useful, though.
95(define (replace-header-contents! name contents headers)
96  (let loop ((h (headers-v headers)))
97    (cond
98     ((null? h)
99      (headers-v-set!
100       headers (cons (cons name contents) (headers-v headers)))
101      headers)
102     ((eq? name (caar h))
103      (set-cdr! (car h) contents)
104      headers)
105     (else (loop (cdr h))))))
106
107(define (replace-header-contents name contents headers)
108  (make-headers
109   (let loop ((h (headers-v headers)))
110     (cond
111      ((null? h) (cons (cons name contents) h))
112      ((eq? name (caar h))
113       (cons (cons (caar h) contents) (cdr h)))
114      (else (cons (car h) (loop (cdr h))))))))
115
116(define (make-updater replacer)
117  (lambda (name contents headers)
118    (let ((old (header-contents name headers '())))
119      (replacer name
120                (if (member name (single-headers))
121                    (list (last contents))
122                    (append old contents))
123                headers))))
124
125(define update-header-contents  (make-updater replace-header-contents))
126(define update-header-contents! (make-updater replace-header-contents!))
127
128(define (string->header-name s) (string->symbol (string-downcase! s)))
129(define (header-name->string h) (string-titlecase (symbol->string h)))
130
131;; Make a header set from a literal expression by folding in the headers
132;; with any previous ones
133(define (headers headers-to-be #!optional (old-headers (make-headers '())))
134  (fold (lambda (h new-headers)
135          (update-header-contents
136           (car h)
137           (map (lambda (v)
138                  (if (vector? v) v (vector v '()))) ; normalize to vector
139                (cdr h))
140           new-headers))
141        old-headers
142        headers-to-be))
143
144(include "header-parsers") ; Also includes header unparsers
145
146;; Any unknown headers are considered to be multi-headers, always
147(define single-headers
148  (make-parameter '(accept-ranges age authorization content-length
149                    content-location content-md5 content-type date etag
150                    expect expires host if-modified-since if-unmodified-since
151                    last-modified location max-forwards proxy-authorization
152                    range referer retry-after server transfer-encoding
153                    user-agent www-authenticate)))
154
155(define string->http-method string->symbol)
156(define http-method->string symbol->string)
157
158;; Hack to insert trailer in chunked ports
159(define *end-of-transfer-object* (list 'eot))
160
161;; Make an output port automatically "chunked"
162(define (chunked-output-port port)
163  (make-output-port (lambda (s) ; write
164                      (if (eq? *end-of-transfer-object* s)
165                          (fprintf port "0\r\n\r\n") ; trailer?
166                          (fprintf port "~X\r\n~A\r\n" (string-length s) s)))
167                    (lambda ()  ; close
168                      (close-output-port port))
169                    (lambda ()  ; flush
170                      (flush-output port))))
171
172;; Make an input port automatically "chunked"
173(define (chunked-input-port port)
174  (let* ((chunk-length 0)
175         (position 0)
176         (check-position (lambda ()
177                           (when (and position (>= position chunk-length))
178                             (unless (zero? chunk-length)
179                                     (read-line port)) ; read \r\n data trailer
180                             (let* ((line (read-line port)))
181                               (if (eof-object? line)
182                                   (set! position #f)
183                                   (begin
184                                     (set! chunk-length (string->number line 16))
185                                     (if chunk-length
186                                         (set! position 0)
187                                         (set! position #f)))))))))
188    (make-input-port (lambda ()         ; read
189                       (check-position)
190                       (if position
191                           (let ((char (read-char port)))
192                             (if (not (eof-object? char))
193                                 (set! position (add1 position)))
194                             char)
195                           #!eof))
196                     (lambda ()          ; ready?
197                       (check-position)
198                       (and position (char-ready? port)))
199                     (lambda ()          ; close
200                       (close-input-port port))
201                     (lambda ()          ; peek
202                       (check-position)
203                       (if position
204                           (peek-char port)
205                           #!eof)))))
206
207;;;;;;;;;;;;;;;;;;;;;;;;;
208;;;; Request parsing ;;;;
209;;;;;;;;;;;;;;;;;;;;;;;;;
210
211;; This includes parsers for all RFC-defined headers
212(define header-parsers
213  (make-parameter
214   `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
215     (accept-charset . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
216     (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
217     (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
218     (accept-ranges . ,(single symbol-parser-ci))
219     (age . ,(single natnum-parser))
220     (allow . ,(multiple symbol-parser))
221     (authorization . ,(single symbol-parser-ci))
222     (cache-control . ,cache-control-parser)
223     (connection . ,(multiple symbol-parser-ci))
224     (content-encoding . ,(multiple symbol-parser-ci))
225     (content-language . ,(multiple symbol-parser-ci))
226     (content-length . ,(single natnum-parser))
227     (content-location . ,(single uri-reference))
228     (content-md5 . ,(single md5-parser))
229     (content-range . ,(single range-parser))
230     (content-type . ,(single symbol-parser-ci))
231     (date . ,(single http-time-parser))
232     (etag . ,entity-tag-parser)
233     (expect . ,(single key/values))
234     (expires . ,(single rfc822-time-parser))
235     (from . ,(multiple mailbox-parser))
236     (host . ,(single host-parser))
237     (if-match . ,(multiple entity-tag-parser))
238     (if-modified-since . ,(single rfc822-time-parser))
239     (if-none-match . ,(multiple entity-tag-parser))
240     (if-range . ,(multiple if-range-parser))
241     (if-unmodified-since . ,(single rfc822-time-parser))
242     (last-modified . ,(single rfc822-time-parser))
243     (location . ,(single uri-reference))
244     (max-forwards . ,(single natnum-parser))
245     (pragma . ,pragma-parser)
246     (proxy-authenticate . ,(multiple symbol-parser-ci))
247     (proxy-authorization . ,(single symbol-parser-ci))
248     (range . ,range-parser)
249     (referer . ,(single uri-reference))
250     (retry-after . ,retry-after-parser)
251     (server . ,product-parser)
252     (te . ,te-parser)
253     (trailer . ,(multiple symbol-parser-ci))
254     (transfer-encoding . ,(single symbol-parser-ci))
255     (upgrade . ,(multiple update-header-contents!))
256     (user-agent . ,product-parser)
257     (vary . ,(multiple symbol-parser-ci))
258     (via . ,via-parser)
259     (warning . ,warning-parser)
260     (www-authenticate . ,(single symbol-parser-ci))
261     ;; RFC 2109
262     (set-cookie . ,set-cookie-parser)
263     (cookie . ,cookie-parser)
264     ;; RFC 2965?
265     )))
266
267;; The parser is supposed to return the new (possibly modified) headers list
268(define (parse-header name contents headers)
269  (let* ((default unknown-header-parser)
270         (parser (alist-ref name (header-parsers) eq? default)))
271    (parser name contents headers)))
272
273(define (parse-header-line line headers)
274  (or
275   (and-let* ((colon-idx   (string-index line #\:))
276              (header-name (string->header-name (string-take line colon-idx)))
277              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
278             (parse-header header-name contents headers))
279   (signal-http-condition "Bad header line" 'header-error 'contents line)))
280
281(define (read-headers port)
282  (let ((first-line (read-line port)))
283    (if (or (eof-object? first-line) (string-null? first-line))
284        (make-headers '())
285        (let loop ((prev-line first-line)
286                   (line      (read-line port))
287                   (headers   (make-headers '())))
288          (if (or (eof-object? line) (string-null? line))
289              (if (string-null? prev-line)
290                  headers
291                  (parse-header-line prev-line headers))
292              (if (char-whitespace? (string-ref line 0)) ; Continuation char?
293                  (loop (string-append prev-line line)
294                        (read-line port)
295                        headers)
296                  (if (string=? (string-take-right prev-line 1) "\\") ; escaped?
297                      ;; XXX Test if this works with all combinations of \r\n
298                      ;; with prepended backslashes. We don't care about
299                      ;; malformed stuff like "foo\\\\\n" or \ with missing "
300                      (loop (string-append prev-line "\n" line)
301                            (read-line port)
302                            headers)
303                      (loop line (read-line port)
304                            (parse-header-line prev-line headers)))))))))
305
306(define (signal-http-condition msg type . more-info)
307  (signal (make-composite-condition
308           (make-property-condition 'http)
309           (apply make-property-condition type more-info)
310           (make-property-condition 'exn 'message msg))))
311
312(defstruct request
313  (method 'GET) uri (major 1) (minor 1) (headers (make-headers '())) port)
314
315;; Perhaps we should have header parsers indexed by version or
316;; something like that, so you can define the maximum version. Useful
317;; for when expecting a response. Then we group request/response parsers
318;; together, as with request/response unparsers.
319(define (http-0.9-request-parser line in)
320  (regex-case line
321    ("[Gg][Ee][Tt] +([^ \t]+)"
322     (_ uri)
323     (make-request method: 'GET uri: (uri-reference uri)
324                   major: 0 minor: 9
325                   port: in))
326    (else #f)))
327
328;; XXX This actually parses anything >= HTTP/1.0
329(define (http-1.x-request-parser line in)
330  (regex-case line
331   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
332    (_ method uri major minor)
333    (make-request method: (string->http-method method) uri: (uri-reference uri)
334                  major: (string->number major)
335                  minor: (string->number minor)
336                  headers: (read-headers in)
337     port: in))
338   (else #f)))
339
340(define request-parsers   ; order matters here
341  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
342
343(define (read-request inport)
344  (let* ((line (read-line inport (read-line-limit)))
345         ;; A bit ugly, but simpler than the alternatives
346         (line (if (eof-object? line) "" line)))
347    ;; Try each parser in turn to process the request-line.
348    ;; A parser returns either #f or a request object
349    (let loop ((parsers (request-parsers)))
350      (if (null? parsers)
351          (signal-http-condition "Unknown protocol" 'unknown-protocol-line
352                                 'line line)
353          (or ((car parsers) line inport) (loop (cdr parsers)))))))
354
355;;;;;;;;;;;;;;;;;;;;;;;;;;;
356;;;; Request unparsing ;;;;
357;;;;;;;;;;;;;;;;;;;;;;;;;;;
358
359(define header-unparsers
360  (make-parameter
361   `((etag . ,entity-tag-unparser)
362     (host . ,host-unparser)
363     (user-agent . ,product-unparser)
364     (server . ,product-unparser))))
365
366(define (unparse-header header-name header-value)
367  (let* ((def default-header-unparser)
368         (unparser (alist-ref header-name (header-unparsers) eq? def)))
369   (unparser header-name header-value)))
370
371(define (unparse-headers headers out)
372  (for-each
373     (lambda (h)
374       (let* ((name (car h))
375              (name-s (header-name->string name))
376              (contents (cdr h)))
377         (fprintf out "~A: ~A\r\n" name-s (unparse-header name contents))))
378     (headers-v headers)))
379
380(define (write-request-line request)
381  (fprintf (request-port request)
382           "~A ~A HTTP/~A.~A\r\n"
383           (request-method request)
384           (uri->string (request-uri request))
385           (request-major request)
386           (request-minor request)))
387
388(define (http-0.9-request-unparser request)
389  (fprintf (request-port request)
390           "GET ~A\r\n"
391           (uri->string (request-uri request)))
392  request)
393
394(define (http-1.0-request-unparser request)
395  (and-let* (((= (request-major request) 1))
396             ((= (request-minor request) 0))
397             (o (request-port request)))
398    (write-request-line request)
399    (unparse-headers (request-headers request) o)
400    (display "\r\n" o)
401    request))
402
403;; XXX This actually unparses anything >= HTTP/1.1
404(define (http-1.x-request-unparser request)
405  (and-let* (((or (> (request-major request) 1)
406                  (and (= (request-major request) 1)
407                       (> (request-minor request) 0))))
408             (o (request-port request)))
409    (write-request-line request)
410    (unparse-headers (request-headers request) o)
411    (display "\r\n" o)
412    (if (memq 'chunked (header-values 'transfer-encoding
413                                      (request-headers request)))
414        (update-request request
415                        port: (chunked-output-port (request-port request)))
416        request)))
417
418(define request-unparsers  ; order matters here
419  (make-parameter (list http-1.x-request-unparser
420                        http-1.0-request-unparser
421                        http-0.9-request-unparser)))
422
423(define (write-request request)
424  ;; Try each unparser in turn to write the request-line.
425  ;; An unparser returns either #f or a new request object.
426  (let loop ((unparsers (request-unparsers)))
427    (if (null? unparsers)
428        (signal-http-condition "Unknown protocol" 'unknown-protocol
429                               'major (request-major request)
430                               'minor (request-minor request))
431        (or ((car unparsers) request) (loop (cdr unparsers))))))
432
433;;;;;;;;;;;;;;;;;;;;;;;;;;;;
434;;;; Response unparsing ;;;;
435;;;;;;;;;;;;;;;;;;;;;;;;;;;;
436
437(defstruct response
438  (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port)
439
440(define (http-0.9-response-unparser response)
441  response) ;; The response-body will just follow
442
443(define (write-response-line response)
444  (fprintf (response-port response)
445           "HTTP/~A.~A ~A ~A\r\n"
446           (response-major response)
447           (response-minor response)
448           (response-code response)
449           (response-reason response)))
450
451(define (http-1.0-response-unparser response)
452  (and-let* (((= (response-major response) 1))
453             ((= (response-minor response) 0))
454             (o (response-port response)))
455    (write-response-line response)
456    (unparse-headers (response-headers response) o)
457    (display "\r\n" o)
458    response))
459
460;; XXX This actually unparses anything >= HTTP/1.1
461(define (http-1.x-response-unparser response)
462  (and-let* (((or (> (response-major response) 1)
463                  (and (= (response-major response) 1)
464                       (> (response-minor response) 0))))
465             (o (response-port response)))
466    (write-response-line response)
467    (unparse-headers (response-headers response) o)
468    (display "\r\n" o)
469    (if (memq 'chunked (header-values 'transfer-encoding
470                                      (response-headers response)))
471        (update-response response
472                         port: (chunked-output-port (response-port response)))
473        response)))
474
475(define response-unparsers
476  (make-parameter (list http-1.x-response-unparser
477                        http-1.0-response-unparser
478                        http-0.9-response-unparser)))
479
480(define (write-response response)
481  ;; Try each unparser in turn to write the response-line.
482  ;; An unparser returns either #f or a new response object.
483  (let loop ((unparsers (response-unparsers)))
484    (if (null? unparsers)
485        (signal-http-condition "Unknown protocol" 'unknown-protocol
486                               'major (response-major response)
487                               'minor (response-minor response))
488        (or ((car unparsers) response) (loop (cdr unparsers))))))
489
490;;;;;;;;;;;;;;;;;;;;;;;;;;
491;;;; Response parsing ;;;;
492;;;;;;;;;;;;;;;;;;;;;;;;;;
493
494;; I don't like this code. Clean it up!
495(define (http-1.x-response-parser line in)
496  (regex-case line
497    ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) +([0-9]+) +(.*)"
498     (_ major minor code reason)
499     (let ((major (string->number major))
500           (minor (string->number minor)))
501      (and (or (> major 1)
502               (and (= major 1)
503                    (> minor 0)))
504           (let ((response (make-response code: (string->number code)
505                                          reason: reason
506                                          major: major
507                                          minor: minor
508                                          headers: (read-headers in)
509                                          port: in)))
510             (if (memq 'chunked (header-values 'transfer-encoding
511                                               (response-headers response)))
512                 (update-response response
513                                  port: (chunked-input-port
514                                         (response-port response)))
515                 response)))))
516    (else #f)))
517
518(define (http-1.0-response-parser line in)
519  (regex-case line
520    ("[Hh][Tt][Tt][Pp]/1\\.0 +([0-9]+) +(.*)"
521     (_ code reason)
522     (let ((response (make-response code: (string->number code) reason: reason
523                                    major: 1 minor: 0
524                                    headers: (read-headers in)
525                                    port: in)))
526       response))
527    (else #f)))
528
529;; You can't "detect" a 0.9 response, because there is no response line.
530;; It will simply output the body directly, so we will just assume that
531;; if we can't recognise the output string, we just got a 0.9 response.
532;; If this is not desired, just change response-parsers to exclude this one.
533(define (http-0.9-response-parser line in)
534  (make-response code: 200 reason: "OK"
535                 major: 0 minor: 9
536                 ;; XXX This is wrong, it re-inserts \r\n, while it may have
537                 ;; been a \n only. To work around this, we'd have to write
538                 ;; a custom read-line procedure.
539                 ;; However, it does not matter much because HTTP 0.9 is only
540                 ;; defined to ever return text/html, no binary or any other
541                 ;; content type.
542                 port: (call-with-input-string (string-append line "\r\n")
543                         (lambda (str)
544                           (make-concatenated-port str in)))))
545
546(define response-parsers ;; order matters here
547  (make-parameter (list http-1.x-response-parser http-1.0-response-parser http-0.9-response-parser)))
548
549(define (read-response inport)
550  (let* ((line (read-line inport (read-line-limit)))
551         (line (if (eof-object? line) "" line)))
552    (let loop ((parsers (response-parsers)))
553      (if (null? parsers)
554          (signal-http-condition "Unknown protocol" 'unknown-protocol-line
555                                 'line line)
556          (or ((car parsers) line inport) (loop (cdr parsers)))))))
557
558)
Note: See TracBrowser for help on using the repository browser.