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

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

Add host parser/unparser

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