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

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

Switch to uri-common

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