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

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

Auto-normalize all uri references in intarweb parsers

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