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

Last change on this file since 12138 was 12138, checked in by sjamaan, 12 years ago

Add base64 to 'needs' list in meta file, add a note to comments

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