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

Last change on this file since 27106 was 27106, checked in by sjamaan, 9 years ago

Also allow disabling of limits

File size: 34.5 KB
Line 
1;;;
2;;; Intarweb is an improved HTTP library for Chicken
3;;;
4;; Copyright (c) 2008-2012, 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;; TODO: Support RFC5987?  Seems awfully messy though (need to pull in iconv?)
34;; We could use http://www.greenbytes.de/tech/tc2231/ in the testsuite.
35;; Look at that URI's toplevel directory for more HTTP/URI-related testcases!
36
37(module intarweb
38  (http-line-limit http-header-limit
39   replace-header-contents replace-header-contents! remove-header remove-header!
40   update-header-contents update-header-contents! headers single-headers
41   headers? headers->list http-name->symbol symbol->http-name
42   header-parsers header-unparsers unparse-header unparse-headers
43   safe-methods safe? idempotent-methods idempotent? keep-alive? response-class
44   etag=? etag=-weakly? etag-matches? etag-matches-weakly?
45   
46   make-request request? request-major request-major-set!
47   request-minor request-minor-set!
48   request-method request-method-set! request-uri request-uri-set!
49   request-headers request-headers-set! request-port request-port-set!
50   update-request set-request! request-has-message-body?
51
52   request-parsers read-request request-unparsers write-request read-headers
53   http-0.9-request-parser http-1.x-request-parser
54   http-0.9-request-unparser http-1.x-request-unparser
55   header-parse-error-handler
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-status response-status-set! response-headers response-headers-set!
61   response-port response-port-set! update-response set-response!
62   response-has-message-body-for-request?
63   
64   write-response response-parsers response-unparsers read-response
65   http-0.9-response-parser http-1.x-response-parser
66   http-0.9-response-unparser http-1.x-response-unparser
67   http-status-codes http-status->code&reason
68
69   ;; http-header-parsers
70   header-contents header-values header-value header-params header-param
71   get-value get-params get-param
72
73   split-multi-header parse-token parse-comment parse-params parse-value+params
74   unparse-params multiple single make-key/value-subparser
75   
76   rfc1123-string->time rfc850-string->time asctime-string->time
77   http-date-string->time
78   rfc1123-subparser rfc850-subparser  asctime-subparser http-date-subparser
79   quality-subparser unknown-header-parser
80   filename-subparser symbol-subparser symbol-subparser-ci natnum-subparser
81   host/port-subparser base64-subparser range-subparser filename-subparser
82   etag-parser product-parser mailbox-subparser if-range-parser
83   retry-after-subparser via-parser warning-parser key/value-subparser
84   set-cookie-parser cache-control-parser pragma-parser te-parser
85   cookie-parser
86   
87   must-be-quoted-chars quote-string unparse-token
88   default-header-unparser etag-unparser host/port-unparser
89   product-unparser rfc1123-unparser cookie-unparser
90
91   ;; Subparsers/subunparsers
92   authorization-param-subparsers
93   basic-auth-param-subparser digest-auth-param-subparser
94   
95   authorization-param-subunparsers
96   basic-auth-param-subunparser digest-auth-param-subunparser
97   )
98
99  (import scheme chicken foreign)
100 
101  (use extras ports data-structures srfi-1 srfi-13 srfi-14 irregex posix
102       base64 defstruct uri-common files)
103
104(define http-line-limit (make-parameter 1024))  ; #f if you want no limit
105(define http-header-limit (make-parameter 256)) ; #f if you want no limit
106
107(define (safe-read-line p)
108  (let* ((limit (http-line-limit))
109         (line (read-line p (http-line-limit))))
110    (if (and (not (eof-object? line)) limit (= limit (string-length line)))
111        (signal-http-condition "Max allowed line length exceeded" (list p)
112                               'line-limit-exceeded 'contents line 'limit limit)
113        line)))
114
115;; Make headers a new type, to force the use of the HEADERS procedure
116;; and ensure only proper header values are passed to all procedures
117;; that deal with headers.
118(define-record headers v)
119
120(define-record-printer (headers h out)
121  (fprintf out "#(headers: ~S)" (headers-v h)))
122
123(define headers->list headers-v)
124
125(define (remove-header! name headers)
126  (let loop ((h (headers-v headers)))
127    (cond
128     ((null? h) headers)
129     ((eq? name (caar h))
130      (set-cdr! h (cdr h))
131      headers)
132     (else (loop (cdr h))))))
133
134(define (remove-header name headers)
135  (make-headers
136   (let loop ((h (headers-v headers)))
137     (cond
138      ((null? h) h)
139      ((eq? name (caar h)) (loop (cdr h)))
140      (else (cons (car h) (loop (cdr h))))))))
141
142;; XXX: Do we need these replace procedures in the exports list?  It
143;; looks like we can use update everywhere.
144(define (replace-header-contents! name contents headers)
145  (let loop ((h (headers-v headers)))
146    (cond
147     ((null? h)
148      (headers-v-set!
149       headers (cons (cons name contents) (headers-v headers)))
150      headers)
151     ((eq? name (caar h))
152      (set-cdr! (car h) contents)
153      headers)
154     (else (loop (cdr h))))))
155
156(define (replace-header-contents name contents headers)
157  (make-headers
158   (let loop ((h (headers-v headers)))
159     (cond
160      ((null? h) (cons (cons name contents) h))
161      ((eq? name (caar h))
162       (cons (cons (caar h) contents) (cdr h)))
163      (else (cons (car h) (loop (cdr h))))))))
164
165(define (make-updater replacer)
166  (lambda (name contents headers)
167    (let ((old (header-contents name headers '())))
168      (replacer name
169                (if (member name (single-headers))
170                    (list (last contents))
171                    (append old contents))
172                headers))))
173
174(define update-header-contents  (make-updater replace-header-contents))
175(define update-header-contents! (make-updater replace-header-contents!))
176
177(define http-name->symbol (compose string->symbol string-downcase!))
178(define symbol->http-name (compose string-titlecase symbol->string))
179
180;; Make a header set from a literal expression by folding in the headers
181;; with any previous ones
182(define (headers headers-to-be #!optional (old-headers (make-headers '())))
183  (fold (lambda (h new-headers)
184          (update-header-contents
185           (car h)
186           (map (lambda (v)
187                  (if (vector? v) v (vector v '()))) ; normalize to vector
188                (cdr h))
189           new-headers))
190        old-headers
191        headers-to-be))
192
193(define (normalized-uri str)
194  (and-let* ((uri (uri-reference str)))
195    (uri-normalize-path-segments uri)))
196
197(include "header-parsers") ; Also includes header unparsers
198
199;; Any unknown headers are considered to be multi-headers, always
200(define single-headers
201  (make-parameter '(accept-ranges age authorization content-disposition
202                    content-length content-location content-md5 content-type
203                    date etag expect expires host if-modified-since
204                    if-unmodified-since last-modified location max-forwards
205                    proxy-authorization range referer retry-after server
206                    transfer-encoding user-agent www-authenticate)))
207
208(define string->http-method string->symbol)
209(define http-method->string symbol->string)
210
211;; Hack to insert trailer in chunked ports
212(define *end-of-transfer-object* (list 'eot))
213
214;; Make an output port automatically "chunked"
215(define (chunked-output-port port)
216  (make-output-port (lambda (s) ; write
217                      (if (eq? *end-of-transfer-object* s)
218                          (fprintf port "0\r\n\r\n") ; trailer?
219                          (fprintf port "~X\r\n~A\r\n" (string-length s) s)))
220                    (lambda ()  ; close
221                      (close-output-port port))
222                    (lambda ()  ; flush
223                      (flush-output port))))
224
225;; Make an input port automatically "chunked"
226(define (chunked-input-port port)
227  (let* ((chunk-length 0)
228         (position 0)
229         (check-position (lambda ()
230                           (when (and position (>= position chunk-length))
231                             (unless (zero? chunk-length)
232                                     (safe-read-line port)) ; read \r\n data trailer
233                             (let* ((line (safe-read-line port)))
234                               (if (eof-object? line)
235                                   (set! position #f)
236                                   (begin
237                                     (set! chunk-length (string->number line 16))
238                                     (if chunk-length
239                                         (set! position 0)
240                                         (set! position #f)))))))))
241    (make-input-port (lambda ()         ; read
242                       (check-position)
243                       (if position
244                           (let ((char (read-char port)))
245                             (if (not (eof-object? char))
246                                 (set! position (add1 position)))
247                             char)
248                           #!eof))
249                     (lambda ()          ; ready?
250                       (check-position)
251                       (and position (char-ready? port)))
252                     (lambda ()          ; close
253                       (close-input-port port))
254                     (lambda ()          ; peek
255                       (check-position)
256                       (if position
257                           (peek-char port)
258                           #!eof)))))
259
260;; RFC2616, Section 4.3: "The presence of a message-body in a request
261;; is signaled by the inclusion of a Content-Length or Transfer-Encoding
262;; header field in the request's message-headers."
263;; We don't check the method since "a server SHOULD read and forward the
264;; a message-body on any request", even it shouldn't be sent for that method.
265(define request-has-message-body?
266  (make-parameter
267   (lambda (req)
268     (let ((headers (request-headers req)))
269       (or (header-contents headers 'content-length)
270           (header-contents headers 'transfer-encoding))))))
271
272;; RFC2616, Section 4.3: "For response messages, whether or not a
273;; message-body is included with a message is dependent on both the
274;; request method and the response status code (section 6.1.1)."
275(define response-has-message-body-for-request?
276  (make-parameter
277   (lambda (resp req)
278     (not (or (= (response-class resp) 100)
279              (memv (response-code resp) '(204 304))
280              (eq? 'HEAD (request-method req)))))))
281
282;; OPTIONS and TRACE are not explicitly mentioned in in section
283;; 9.1.1, but section 9.1.2 says they SHOULD NOT have side-effects
284;; by definition, which means they are safe, as well.
285(define safe-methods
286  (make-parameter '(GET HEAD OPTIONS TRACE)))
287
288;; RFC2616, Section 9.1.1
289(define (safe? obj)
290  (let ((method (if (request? obj) (request-method obj) obj)))
291    (not (not (member method (safe-methods))))))
292
293(define idempotent-methods
294  (make-parameter '(GET HEAD PUT DELETE OPTIONS TRACE)))
295
296;; RFC2616, Section 9.1.2
297(define (idempotent? obj)
298  (let ((method (if (request? obj) (request-method obj) obj)))
299    (not (not (member method (idempotent-methods))))))
300
301(define (keep-alive? obj)
302  (let ((major (if (request? obj) (request-major obj) (response-major obj)))
303        (minor (if (request? obj) (request-minor obj) (response-minor obj)))
304        (con   (header-value 'connection (if (request? obj)
305                                             (request-headers obj)
306                                             (response-headers obj)))))
307   (if (and (= major 1) (> minor 0))
308       (not (eq? con 'close))
309       ;; RFC 2068, section 19.7.1 (see also RFC 2616, section 19.6.2)
310       (eq? con 'keep-alive))))
311
312(define (etag=? a b)
313  (and (not (eq? 'weak (car a)))
314       (eq? (car a) (car b))
315       (string=? (cdr a) (cdr b))))
316
317(define (etag=-weakly? a b)
318  (and (eq? (car a) (car b))
319       (string=? (cdr a) (cdr b))))
320
321(define (etag-matches? etag matchlist)
322  (any (lambda (m) (or (eq? m '*) (etag=? etag m))) matchlist))
323
324(define (etag-matches-weakly? etag matchlist)
325  (any (lambda (m) (or (eq? m '*) (etag=-weakly? etag m))) matchlist))
326
327;;;;;;;;;;;;;;;;;;;;;;;;;
328;;;; Request parsing ;;;;
329;;;;;;;;;;;;;;;;;;;;;;;;;
330
331;; This includes parsers for all RFC-defined headers
332(define header-parsers
333  (make-parameter
334   `((accept . ,(multiple symbol-subparser-ci
335                          `((q . ,quality-subparser))))
336     (accept-charset . ,(multiple symbol-subparser-ci
337                                  `((q . ,quality-subparser))))
338     (accept-encoding . ,(multiple symbol-subparser-ci
339                                   `((q . ,quality-subparser))))
340     (accept-language . ,(multiple symbol-subparser-ci
341                                   `((q . ,quality-subparser))))
342     (accept-ranges . ,(single symbol-subparser-ci))
343     (age . ,(single natnum-subparser))
344     (allow . ,(multiple symbol-subparser))
345     (authorization . ,authorization-parser)
346     (cache-control . ,cache-control-parser)
347     (connection . ,(multiple symbol-subparser-ci))
348     (content-encoding . ,(multiple symbol-subparser-ci))
349     (content-language . ,(multiple symbol-subparser-ci))
350     (content-length . ,(single natnum-subparser))
351     (content-location . ,(single normalized-uri))
352     (content-md5 . ,(single base64-subparser))
353     (content-range . ,(single range-subparser))
354     (content-type . ,(single symbol-subparser-ci
355                              `((charset . ,symbol-subparser-ci))))
356     (date . ,(single http-date-subparser))
357     (etag . ,etag-parser)
358     (expect . ,(single (make-key/value-subparser '())))
359     (expires . ,(single http-date-subparser))
360     (from . ,(multiple mailbox-subparser))
361     (host . ,(single host/port-subparser))
362     (if-match . ,if-match-parser)
363     (if-modified-since . ,(single http-date-subparser))
364     (if-none-match . ,if-match-parser)
365     (if-range . ,if-range-parser)
366     (if-unmodified-since . ,(single http-date-subparser))
367     (last-modified . ,(single http-date-subparser))
368     (location . ,(single normalized-uri))
369     (max-forwards . ,(single natnum-subparser))
370     (pragma . ,pragma-parser)
371     (proxy-authenticate . ,authenticate-parser)
372     (proxy-authorization . ,authorization-parser)
373     (range . ,(multiple range-subparser))
374     (referer . ,(single normalized-uri))
375     (retry-after . ,(single retry-after-subparser))
376     (server . ,product-parser)
377     (te . ,te-parser)
378     (trailer . ,(multiple symbol-subparser-ci))
379     (transfer-encoding . ,(single symbol-subparser-ci))
380     (upgrade . ,(multiple update-header-contents!))
381     (user-agent . ,product-parser)
382     (vary . ,(multiple symbol-subparser-ci))
383     (via . ,via-parser)
384     (warning . ,warning-parser)
385     (www-authenticate . ,authenticate-parser)
386     ;; RFC 2183
387     (content-disposition . ,(single symbol-subparser-ci
388                                     `((filename . ,filename-subparser)
389                                       (creation-date . ,rfc1123-subparser)
390                                       (modification-date . ,rfc1123-subparser)
391                                       (read-date . ,rfc1123-subparser)
392                                       (size . ,natnum-subparser))))
393     ;; RFC 2109
394     (set-cookie . ,set-cookie-parser)
395     (cookie . ,cookie-parser)
396     ;; RFC 2965?
397     ;; Nonstandard but common headers
398     (x-forwarded-for . ,(multiple identity))
399     )))
400
401(define header-parse-error-handler ;; ignore errors
402  (make-parameter (lambda (header-name contents headers exn) headers)))
403
404;; The parser is supposed to return a list of header values for its header
405(define (parse-header name contents)
406  (let* ((default unknown-header-parser)
407         (parser (alist-ref name (header-parsers) eq? default)))
408    (parser contents)))
409
410(define (parse-header-line line headers)
411  (or
412   (and-let* ((colon-idx   (string-index line #\:))
413              (header-name (http-name->symbol (string-take line colon-idx)))
414              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
415     (handle-exceptions
416      exn
417      ((header-parse-error-handler) header-name contents headers exn)
418      (update-header-contents!
419       header-name (parse-header header-name contents) headers)))
420   (signal-http-condition "Bad header line" (list line) 'header-error 'contents line)))
421
422(define (read-headers port)
423  (let ((first-line (safe-read-line port))
424        (limit (http-header-limit)))
425    (if (or (eof-object? first-line) (string-null? first-line))
426        (make-headers '())
427        (let loop ((num-lines 2)
428                   (prev-line first-line)
429                   (line      (safe-read-line port))
430                   (headers   (make-headers '())))
431          (cond
432           ((or (eof-object? line) (string-null? line))
433            (if (string-null? prev-line)
434                headers
435                (parse-header-line prev-line headers)))
436           ((and limit (> num-lines limit))
437            (signal-http-condition "Max allowed header count exceeded"
438                                   (list port)
439                                   'header-limit-exceeded
440                                   'contents line 'limit limit))
441           ((char-whitespace? (string-ref line 0)) ; Continuation char?
442            ;; This shouldn't count a new header line but add to the read-limit
443            (loop (add1 num-lines)
444                  (string-append prev-line line)
445                  (safe-read-line port)
446                  headers))
447           ((string=? (string-take-right prev-line 1) "\\") ; escaped?
448            ;; XXX Test if this works with all combinations of \r\n
449            ;; with prepended backslashes. We don't care about
450            ;; malformed stuff like "foo\\\\\n" or \ with missing "
451            (loop (add1 num-lines)
452                  (string-append prev-line "\n" line)
453                  (safe-read-line port) headers))
454           (else (loop (add1 num-lines) line (safe-read-line port)
455                       (parse-header-line prev-line headers))))))))
456
457(define (signal-http-condition msg args type . more-info)
458  (signal (make-composite-condition
459           (make-property-condition 'http)
460           (apply make-property-condition type more-info)
461           (make-property-condition 'exn 'message msg 'arguments args))))
462
463(defstruct request
464  (method 'GET) uri (major 1) (minor 1) (headers (make-headers '())) port)
465
466;; Perhaps we should have header parsers indexed by version or
467;; something like that, so you can define the maximum version. Useful
468;; for when expecting a response. Then we group request/response parsers
469;; together, as with request/response unparsers.
470(define http-0.9-request-parser
471  (let ((req (irregex '(seq (w/nocase "GET") (+ space) (=> uri (* any))))))
472    (lambda (line in)
473      (and-let* ((m (irregex-match req line))
474                 (uri (normalized-uri (irregex-match-substring m 'uri))))
475        (make-request method: 'GET uri: uri
476                      major: 0 minor: 9 port: in)))))
477
478;; Might want to reuse this elsewhere
479(define token-sre '(+ (~ "()<>@,;:\\\"/[]?={}\t ")))
480
481;; XXX This actually parses anything >= HTTP/1.0
482(define http-1.x-request-parser
483  (let ((req (irregex `(seq (=> method ,token-sre) (+ space)
484                            (=> uri (+ (~ blank))) ; uri-common handles details
485                            (+ space) (w/nocase "HTTP/")
486                            (=> major (+ digit)) "." (=> minor (+ digit))))))
487    (lambda (line in)
488      (and-let* ((m (irregex-match req line))
489                 (uri (normalized-uri (irregex-match-substring m 'uri)))
490                 (major (string->number (irregex-match-substring m 'major)))
491                 (minor (string->number (irregex-match-substring m 'minor)))
492                 (method (string->http-method (irregex-match-substring m 'method)))
493                 (headers (read-headers in)))
494        (make-request method: method uri: uri
495                      major: major minor: minor
496                      headers: headers
497                      port: in)))))
498
499(define request-parsers   ; order matters here
500  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
501
502(define (read-request inport)
503  (let* ((line (safe-read-line inport))
504         ;; A bit ugly, but simpler than the alternatives
505         (line (if (eof-object? line) "" line)))
506    ;; Try each parser in turn to process the request-line.
507    ;; A parser returns either #f or a request object
508    (let loop ((parsers (request-parsers)))
509      (if (null? parsers)
510          (signal-http-condition "Unknown protocol line" line
511                                 'unknown-protocol-line 'line line)
512          (or ((car parsers) line inport) (loop (cdr parsers)))))))
513
514;;;;;;;;;;;;;;;;;;;;;;;;;;;
515;;;; Request unparsing ;;;;
516;;;;;;;;;;;;;;;;;;;;;;;;;;;
517
518(define header-unparsers
519  (make-parameter
520   `((content-disposition . ,content-disposition-unparser)
521     (date . ,rfc1123-unparser)
522     (etag . ,etag-unparser)
523     (expires . ,rfc1123-unparser)
524     (host . ,host/port-unparser)
525     (if-match . ,if-match-unparser)
526     (if-modified-since . ,rfc1123-unparser)
527     (if-none-match . ,if-match-unparser)
528     (if-unmodified-since . ,rfc1123-unparser)
529     (last-modified . ,rfc1123-unparser)
530     (user-agent . ,product-unparser)
531     (server . ,product-unparser)
532     (cookie . ,cookie-unparser)
533     (set-cookie . ,set-cookie-unparser)
534     (authorization . ,authorization-unparser)
535     (www-authenticate . ,authenticate-unparser)
536     (proxy-authorization . ,authorization-unparser)
537     (proxy-authenticate . ,authenticate-unparser))))
538
539(define (unparse-header header-name header-value)
540  (let* ((def default-header-unparser)
541         (unparser (alist-ref header-name (header-unparsers) eq? def)))
542   (unparser header-value)))
543
544(define (unparse-headers headers out)
545  (for-each
546     (lambda (h)
547       (let* ((name (car h))
548              (name-s (symbol->http-name name))
549              (contents (cdr h)))
550         (for-each (lambda (value)
551                     ;; Verify there's no \r\n or \r or \n in value?
552                     (fprintf out "~A: ~A\r\n" name-s value))
553                   (unparse-header name contents))))
554     (headers-v headers)))
555
556(define (write-request-line request)
557  (fprintf (request-port request)
558           "~A ~A HTTP/~A.~A\r\n"
559           (http-method->string (request-method request))
560           (uri->string (request-uri request))
561           (request-major request)
562           (request-minor request)))
563
564(define (http-0.9-request-unparser request)
565  (fprintf (request-port request)
566           "GET ~A\r\n"
567           (uri->string (request-uri request)))
568  request)
569
570(define (http-1.0-request-unparser request)
571  (and-let* (((= (request-major request) 1))
572             ((= (request-minor request) 0))
573             (o (request-port request)))
574    (write-request-line request)
575    (unparse-headers (request-headers request) o)
576    (display "\r\n" o)
577    request))
578
579;; XXX This actually unparses anything >= HTTP/1.1
580(define (http-1.x-request-unparser request)
581  (and-let* (((or (> (request-major request) 1)
582                  (and (= (request-major request) 1)
583                       (> (request-minor request) 0))))
584             (o (request-port request)))
585    (write-request-line request)
586    (unparse-headers (request-headers request) o)
587    (display "\r\n" o)
588    (if (memq 'chunked (header-values 'transfer-encoding
589                                      (request-headers request)))
590        (update-request request
591                        port: (chunked-output-port (request-port request)))
592        request)))
593
594(define request-unparsers  ; order matters here
595  (make-parameter (list http-1.x-request-unparser
596                        http-1.0-request-unparser
597                        http-0.9-request-unparser)))
598
599(define (write-request request)
600  ;; Try each unparser in turn to write the request-line.
601  ;; An unparser returns either #f or a new request object.
602  (let loop ((unparsers (request-unparsers)))
603    (if (null? unparsers)
604        (let ((major (request-major request))
605              (minor (request-minor request)))
606         (signal-http-condition "Unknown protocol" (list (conc major "." minor))
607                                'unknown-protocol 'major major 'minor minor))
608        (or ((car unparsers) request) (loop (cdr unparsers))))))
609
610;;;;;;;;;;;;;;;;;;;;;;;;;;;;
611;;;; Response unparsing ;;;;
612;;;;;;;;;;;;;;;;;;;;;;;;;;;;
613
614(defstruct response
615  (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port)
616
617(define make-response
618  (let ((old-make-response make-response))
619    (lambda (#!rest args #!key status code reason)
620      (let ((resp (apply old-make-response args)))
621        (when (and status (not code) (not reason))
622          (response-status-set! resp status))
623        resp))))
624
625(define update-response
626  (let ((old-update-response update-response))
627    (lambda (resp #!rest args #!key status code reason)
628      (let ((resp (apply old-update-response resp args)))
629        (when (and status (not code) (not reason))
630          (response-status-set! resp status))
631        resp))))
632
633(define (response-status-set! resp status)
634  (receive (code reason) (http-status->code&reason status)
635    (response-code-set! resp code)
636    (response-reason-set! resp reason)
637    resp))
638
639(define (response-class obj)
640  (let ((code (if (response? obj) (response-code obj) obj)))
641    (- code (modulo code 100))))
642
643(define (response-status obj)
644  (let* ((c (if (response? obj) (response-code obj) obj))
645         (s (find (lambda (x) (= (cadr x) c)) (http-status-codes))))
646    (if s
647        (car s)
648        (signal-http-condition "Unknown status code" (list c)
649                               'unknown-code 'code c))))
650
651(define (http-status->code&reason status)
652  (let ((s (alist-ref status (http-status-codes))))
653    (unless s
654      (signal-http-condition "Unknown response status symbol" (list status)
655                             'unknown-status 'status status))
656    (values (car s) (cdr s))))
657
658(define http-status-codes
659  (make-parameter 
660   `((continue . (100 . "Continue"))
661     (switching-protocols . (101 . "Switching Protocols"))
662     (ok . (200 . "OK"))
663     (created . (201 . "Created"))
664     (accepted . (202 . "Accepted"))
665     (non-authoritative-information . (203 . "Non-Authoritative Information"))
666     (no-content . (204 . "No Content"))
667     (reset-content . (205 . "Reset Content"))
668     (partial-content . (206 . "Partial Content"))
669     (multiple-choices . (300 . "Multiple Choices"))
670     (moved-permanently . (301 . "Moved Permanently"))
671     (found . (302 . "Found"))
672     (see-other . (303 . "See Other"))
673     (not-modified . (304 . "Not Modified"))
674     (use-proxy . (305 . "Use Proxy"))
675     (temporary-redirect . (307 . "Temporary Redirect"))
676     (bad-request . (400 . "Bad Request"))
677     (unauthorized . (401 . "Unauthorized"))
678     (payment-required . (402 . "Payment Required"))
679     (forbidden . (403 . "Forbidden"))
680     (not-found . (404 . "Not Found"))
681     (method-not-allowed . (405 . "Method Not Allowed"))
682     (not-acceptable . (406 . "Not Acceptable"))
683     (proxy-authentication-required . (407 . "Proxy Authentication Required"))
684     (request-time-out . (408 . "Request Time-out"))
685     (conflict . (409 . "Conflict"))
686     (gone . (410 . "Gone"))
687     (length-required . (411 . "Length Required"))
688     (precondition-failed . (412 . "Precondition Failed"))
689     (request-entity-too-large . (413 . "Request Entity Too Large"))
690     (request-uri-too-large . (414 . "Request-URI Too Large"))
691     (unsupported-media-type . (415 . "Unsupported Media Type"))
692     (request-range-not-satisfiable . (416 . "Requested range not satisfiable"))
693     (expectation-failed . (417 . "Expectation Failed"))
694     (internal-server-error . (500 . "Internal Server Error"))
695     (not-implemented . (501 . "Not Implemented"))
696     (bad-gateway . (502 . "Bad Gateway"))
697     (service-unavailable . (503 . "Service Unavailable"))
698     (gateway-time-out . (504 . "Gateway Time-out"))
699     (http-version-not-supported . (505 . "HTTP Version not supported")))))
700
701(define (http-0.9-response-unparser response)
702  response) ;; The response-body will just follow
703
704(define (write-response-line response)
705  (fprintf (response-port response)
706           "HTTP/~A.~A ~A ~A\r\n"
707           (response-major response)
708           (response-minor response)
709           (response-code response)
710           (response-reason response)))
711
712(define (http-1.0-response-unparser response)
713  (and-let* (((= (response-major response) 1))
714             ((= (response-minor response) 0))
715             (o (response-port response)))
716    (write-response-line response)
717    (unparse-headers (response-headers response) o)
718    (display "\r\n" o)
719    response))
720
721;; XXX This actually unparses anything >= HTTP/1.1
722(define (http-1.x-response-unparser response)
723  (and-let* (((or (> (response-major response) 1)
724                  (and (= (response-major response) 1)
725                       (> (response-minor response) 0))))
726             (o (response-port response)))
727    (write-response-line response)
728    (unparse-headers (response-headers response) o)
729    (display "\r\n" o)
730    (if (memq 'chunked (header-values 'transfer-encoding
731                                      (response-headers response)))
732        (update-response response
733                         port: (chunked-output-port (response-port response)))
734        response)))
735
736(define response-unparsers
737  (make-parameter (list http-1.x-response-unparser
738                        http-1.0-response-unparser
739                        http-0.9-response-unparser)))
740
741(define (write-response response)
742  ;; Try each unparser in turn to write the response-line.
743  ;; An unparser returns either #f or a new response object.
744  (let loop ((unparsers (response-unparsers)))
745    (if (null? unparsers)
746        (let ((major (response-major response))
747              (minor (response-minor response)))
748         (signal-http-condition "Unknown protocol" (list (conc major "." minor))
749                                'unknown-protocol 'major major 'minor minor))
750        (or ((car unparsers) response) (loop (cdr unparsers))))))
751
752;;;;;;;;;;;;;;;;;;;;;;;;;;
753;;;; Response parsing ;;;;
754;;;;;;;;;;;;;;;;;;;;;;;;;;
755
756(define http-1.x-response-parser
757  (let ((resp (irregex '(seq (w/nocase "HTTP/")
758                             (=> major (+ digit)) "." (=> minor (+ digit))
759                             ;; Could use '(= 3 digit) for status-code, but
760                             ;; that's currently not compilable
761                             (+ space) (=> status-code digit digit digit)
762                             (+ space) (=> reason-phrase (* nonl))))))
763    (lambda (line in)
764      (and-let* ((m (irregex-match resp line))
765                 (code (string->number (irregex-match-substring m 'status-code)))
766                 (major (string->number (irregex-match-substring m 'major)))
767                 (minor (string->number (irregex-match-substring m 'minor)))
768                 ((or (> major 1) (and (= major 1) (> minor 0))))
769                 (reason (irregex-match-substring m 'reason-phrase))
770                 (h (read-headers in))
771                 (port (if (memq 'chunked (header-values 'transfer-encoding h))
772                           (chunked-input-port in)
773                           in)))
774        (make-response code: code reason: reason
775                       major: major minor: minor
776                       headers: h
777                       port: port)))))
778
779(define http-1.0-response-parser
780  (let ((resp (irregex '(seq (w/nocase "HTTP/1.0")
781                             ;; Could use '(= 3 digit) for status-code, but
782                             ;; that's currently not compilable
783                             (+ space) (=> status-code digit digit digit)
784                             (+ space) (=> reason-phrase (* nonl))))))
785    (lambda (line in)
786      (and-let* ((m (irregex-match resp line))
787                 (code (string->number (irregex-match-substring m 'status-code)))
788                 (reason (irregex-match-substring m 'reason-phrase))
789                 (h (read-headers in)))
790        ;; HTTP/1.0 has no chunking
791        (make-response code: code reason: reason
792                       major: 1 minor: 0
793                       headers: h
794                       port: in)))))
795
796;; You can't "detect" a 0.9 response, because there is no response line.
797;; It will simply output the body directly, so we will just assume that
798;; if we can't recognise the output string, we just got a 0.9 response.
799;; If this is not desired, just change response-parsers to exclude this one.
800(define (http-0.9-response-parser line in)
801  (make-response code: 200 reason: "OK"
802                 major: 0 minor: 9
803                 ;; XXX This is wrong, it re-inserts \r\n, while it may have
804                 ;; been a \n only. To work around this, we'd have to write
805                 ;; a custom (safe-)read-line procedure.
806                 ;; However, it does not matter much because HTTP 0.9 is only
807                 ;; defined to ever return text/html, no binary or any other
808                 ;; content type.
809                 port: (call-with-input-string (string-append line "\r\n")
810                         (lambda (str)
811                           (make-concatenated-port str in)))))
812
813(define response-parsers ;; order matters here
814  (make-parameter (list http-1.x-response-parser http-1.0-response-parser http-0.9-response-parser)))
815
816(define (read-response inport)
817  (let* ((line (safe-read-line inport))
818         (line (if (eof-object? line) "" line)))
819    (let loop ((parsers (response-parsers)))
820      (if (null? parsers)
821          (signal-http-condition "Unknown protocol" (list line)
822                                 'unknown-protocol-line 'line line)
823          (or ((car parsers) line inport) (loop (cdr parsers)))))))
824
825)
Note: See TracBrowser for help on using the repository browser.