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

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

intarweb: Add some TODOs

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