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

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

OPTIONS and TRACE are safe, as well, but not mentioned clearly in the standard (bad RFC writers, bad!)

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