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

Last change on this file since 14574 was 14574, checked in by sjamaan, 10 years ago

Rearrange code so it has a more logical source order. Rename all subparsers so they end in -subparser (finding bugs in the process). Fix export list

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