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

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

Add keep-alive? predicate for request and response objects

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