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

Last change on this file since 14361 was 14361, checked in by Jim Ursetto, 11 years ago

intarweb: dep on regex-case, use base64 3.0 API

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