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

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

Implement http-date unparsers. Change all date unparsers to http-date-unparsers

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