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

Last change on this file since 11914 was 11914, checked in by sjamaan, 13 years ago

Implement improvement for entity-tag parser which makes it distinguish between quoted strong headers starting with 'W/' as value and regular weak headers

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