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

Last change on this file since 15091 was 15091, checked in by sjamaan, 10 years ago

Add a cookie unparser

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