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

Last change on this file since 32414 was 32414, checked in by sjamaan, 6 years ago

Summary: intarweb: Move header count limit check into code that handles adding the header

File size: 42.9 KB
Line 
1;;;
2;;; Intarweb is an improved HTTP library for Chicken
3;;;
4;; Copyright (c) 2008-2015, 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 http-urlencoded-request-data-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 read-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
53   finish-request-body http-0.9-request-parser http-1.x-request-parser
54   http-0.9-request-unparser http-1.0-request-unparser http-1.x-request-unparser
55   header-parse-error-handler
56   read-urlencoded-request-data
57   
58   make-response response? response-major response-major-set!
59   response-minor response-minor-set!
60   response-code response-code-set! response-reason response-reason-set!
61   response-status response-status-set! response-headers response-headers-set!
62   response-port response-port-set! update-response set-response!
63   response-has-message-body-for-request?
64   
65   write-response response-parsers response-unparsers read-response
66   finish-response-body http-0.9-response-parser http-0.9-response-unparser
67   http-1.0-response-parser http-1.0-response-unparser
68   http-1.x-response-parser http-1.x-response-unparser
69   http-status-codes http-status->code&reason
70
71   ;; http-header-parsers
72   header-contents header-values header-value header-params header-param
73   get-value get-params get-param
74
75   split-multi-header parse-token parse-comment
76   parse-params parse-value+params unparse-params
77   multiple single make-key/value-subparser
78   
79   rfc1123-string->time rfc850-string->time asctime-string->time
80   http-date-string->time
81   rfc1123-subparser rfc850-subparser  asctime-subparser http-date-subparser
82   product-subparser quality-subparser unknown-header-parser
83   filename-subparser symbol-subparser symbol-subparser-ci natnum-subparser
84   host/port-subparser base64-subparser range-subparser filename-subparser
85   etag-parser software-parser mailbox-subparser
86   if-range-parser retry-after-subparser via-parser warning-parser
87   key/value-subparser set-cookie-parser cache-control-parser pragma-parser
88   te-parser cookie-parser strict-transport-security-parser
89   
90   must-be-quoted-chars quote-string unparse-token
91   default-header-unparser etag-unparser host/port-unparser
92   product-unparser software-unparser rfc1123-unparser cookie-unparser
93   strict-transport-security-unparser
94
95   ;; Subparsers/subunparsers
96   authorization-param-subparsers
97   basic-auth-param-subparser digest-auth-param-subparser
98   
99   authorization-param-subunparsers
100   basic-auth-param-subunparser digest-auth-param-subunparser
101   )
102
103  (import scheme chicken foreign)
104 
105  (use extras ports data-structures srfi-1 srfi-13 srfi-14 irregex posix
106       base64 defstruct uri-common files)
107
108;; The below can all be #f if you want no limit (not recommended!)
109(define http-line-limit (make-parameter 4096))
110(define http-header-limit (make-parameter 64))
111(define http-urlencoded-request-data-limit (make-parameter (* 4 1024 1024)))
112
113(define (read-urlencoded-request-data
114         request #!optional (max-length (http-urlencoded-request-data-limit)))
115  (let* ((p (request-port request))
116         (len (header-value 'content-length (request-headers request)))
117         ;; For simplicity's sake, we don't allow exactly the max request limit
118         (limit (if (and len max-length)
119                    (min len max-length)
120                    (or max-length len)))
121         (data (read-string limit (request-port request))))
122    (if (and (not (eof-object? data)) max-length (= max-length (string-length data)))
123        (signal-http-condition "Max allowed URLencoded request size exceeded"
124                               (list request max-length)
125                               'urlencoded-request-data-limit-exceeded
126                               'contents data 'limit limit)
127        (form-urldecode data))))
128
129(define (raise-line-limit-exceeded-error line limit port)
130  (let ((safe-line-prefix
131         (if (< limit 128)
132             (sprintf "~A[..and more (was limited to ~A)..]" line limit)
133             (sprintf "~A[..~A+ more chars (was limited to ~A)..]"
134               (substring line 0 128) (- limit 128) limit))))
135    (signal-http-condition "Max allowed line length exceeded"
136                           (list port safe-line-prefix)
137                           'line-limit-exceeded 'contents line 'limit limit)))
138
139(define (safe-read-line p)
140  (let* ((limit (http-line-limit))
141         (line (read-line p (http-line-limit))))
142    (if (and (not (eof-object? line)) limit (= limit (string-length line)))
143        (raise-line-limit-exceeded-error line limit p)
144        line)))
145
146;; Make headers a new type, to force the use of the HEADERS procedure
147;; and ensure only proper header values are passed to all procedures
148;; that deal with headers.
149(define-record headers v)
150
151(define-record-printer (headers h out)
152  (fprintf out "#(headers: ~S)" (headers-v h)))
153
154(define headers->list headers-v)
155
156(define (remove-header! name headers)
157  (let loop ((h (headers-v headers)))
158    (cond
159     ((null? h) headers)
160     ((eq? name (caar h))
161      (set-cdr! h (cdr h))
162      headers)
163     (else (loop (cdr h))))))
164
165(define (remove-header name headers)
166  (make-headers
167   (let loop ((h (headers-v headers)))
168     (cond
169      ((null? h) h)
170      ((eq? name (caar h)) (loop (cdr h)))
171      (else (cons (car h) (loop (cdr h))))))))
172
173;; XXX: Do we need these replace procedures in the exports list?  It
174;; looks like we can use update everywhere.
175(define (replace-header-contents! name contents headers)
176  (let loop ((h (headers-v headers)))
177    (cond
178     ((null? h)
179      (headers-v-set!
180       headers (cons (cons name contents) (headers-v headers)))
181      headers)
182     ((eq? name (caar h))
183      (set-cdr! (car h) contents)
184      headers)
185     (else (loop (cdr h))))))
186
187(define (replace-header-contents name contents headers)
188  (make-headers
189   (let loop ((h (headers-v headers)))
190     (cond
191      ((null? h) (cons (cons name contents) h))
192      ((eq? name (caar h))
193       (cons (cons (caar h) contents) (cdr h)))
194      (else (cons (car h) (loop (cdr h))))))))
195
196(define (make-updater replacer)
197  (lambda (name contents headers)
198    (let ((old (header-contents name headers '())))
199      (replacer name
200                (if (member name (single-headers))
201                    (list (last contents))
202                    (append old contents))
203                headers))))
204
205(define update-header-contents  (make-updater replace-header-contents))
206(define update-header-contents! (make-updater replace-header-contents!))
207
208(define http-name->symbol (compose string->symbol string-downcase!))
209(define symbol->http-name (compose string-titlecase symbol->string))
210
211;; Make a header set from a literal expression by folding in the headers
212;; with any previous ones
213(define (headers headers-to-be #!optional (old-headers (make-headers '())))
214  (fold (lambda (h new-headers)
215          (update-header-contents
216           (car h)
217           (map (lambda (v)
218                  (if (vector? v) v (vector v '()))) ; normalize to vector
219                (cdr h))
220           new-headers))
221        old-headers
222        headers-to-be))
223
224(define (normalized-uri str)
225  (and-let* ((uri (uri-reference str)))
226    (uri-normalize-path-segments uri)))
227
228(include "header-parsers") ; Also includes header unparsers
229
230;; Any unknown headers are considered to be multi-headers, always
231(define single-headers
232  (make-parameter '(accept-ranges age authorization content-disposition
233                    content-length content-location content-md5 content-type
234                    date etag expect expires host if-modified-since
235                    if-unmodified-since last-modified location max-forwards
236                    proxy-authorization range referer retry-after server
237                    transfer-encoding user-agent www-authenticate)))
238
239(define string->http-method string->symbol)
240(define http-method->string symbol->string)
241
242;; Make an output port automatically "chunked"
243(define (chunked-output-port port)
244  (let ((chunked-port
245         (make-output-port (lambda (s)        ; write
246                             (let ((len (string-length s)))
247                               (unless (zero? len)
248                                 (fprintf port "~X\r\n~A\r\n" len s))))
249                           (lambda ()         ; close
250                             (close-output-port port))
251                           (lambda ()         ; flush
252                             (flush-output port)))))
253    ;; first "reserved" slot
254    ;; Slot 7 should probably stay 'custom
255    (##sys#setslot chunked-port 10 'chunked-output-port)
256    ;; second "reserved" slot
257    (##sys#setslot chunked-port 11 port)
258    chunked-port))
259
260;; Make an input port automatically "chunked"
261(define (chunked-input-port port)
262  (let* ((chunk-length 0)
263         (position 0)
264         (check-position (lambda ()
265                           (when (and position (>= position chunk-length))
266                             (unless (eq? chunk-length 0)
267                               (safe-read-line port)) ; Read \r\n data trailer
268                             (let ((line (safe-read-line port)))
269                               (if (eof-object? line)
270                                   (set! position #f)
271                                   (begin
272                                     (set! chunk-length (string->number line 16))
273                                     (cond
274                                      ((not chunk-length) (set! position #f))
275                                      ((zero? chunk-length) ; Read final data trailer
276                                       (safe-read-line port)
277                                       (set! position #f))
278                                      (else (set! position 0))))))))))
279    (make-input-port (lambda ()         ; read-char
280                       (check-position)
281                       (if position
282                           (let ((char (read-char port)))
283                             (unless (eof-object? char)
284                               (set! position (add1 position)))
285                             char)
286                           #!eof))
287                     (lambda ()         ; ready?
288                       (check-position)
289                       (or (not position) (char-ready? port)))
290                     (lambda ()         ; close
291                       (close-input-port port))
292                     (lambda ()         ; peek-char
293                       (check-position)
294                       (if position
295                           (peek-char port)
296                           #!eof))
297                     (lambda (p bytes buf off) ; read-string!
298                       (let lp ((todo bytes)
299                                (total-bytes-read 0)
300                                (off off))
301                         (check-position)
302                         (if (or (not position) (= todo 0))
303                             total-bytes-read
304                             (let* ((n (min todo (- chunk-length position)))
305                                    (bytes-read (read-string! n buf port off)))
306                               (set! position (+ position bytes-read))
307                               (lp (- todo bytes-read)
308                                   (+ total-bytes-read bytes-read)
309                                   (+ off bytes-read)))))))))
310;; TODO: Note that in the above, read-line is not currently
311;; implemented.  It is *extremely* tricky to correctly maintain the
312;; port position when all \r *AND/OR* \n characters get chopped off
313;; the line-string.  It can be done by maintaining our own extra
314;; buffer, but that complicates all the procedures here enormously,
315;; including read-line itself.
316
317;; RFC2616, Section 4.3: "The presence of a message-body in a request
318;; is signaled by the inclusion of a Content-Length or Transfer-Encoding
319;; header field in the request's message-headers."
320;; We don't check the method since "a server SHOULD read and forward the
321;; a message-body on any request", even it shouldn't be sent for that method.
322(define request-has-message-body?
323  (make-parameter
324   (lambda (req)
325     (let ((headers (request-headers req)))
326       (or (header-contents 'content-length headers)
327           (header-contents 'transfer-encoding headers))))))
328
329;; RFC2616, Section 4.3: "For response messages, whether or not a
330;; message-body is included with a message is dependent on both the
331;; request method and the response status code (section 6.1.1)."
332(define response-has-message-body-for-request?
333  (make-parameter
334   (lambda (resp req)
335     (not (or (= (response-class resp) 100)
336              (memv (response-code resp) '(204 304))
337              (eq? 'HEAD (request-method req)))))))
338
339;; OPTIONS and TRACE are not explicitly mentioned in section 9.1.1,
340;; but section 9.1.2 says they SHOULD NOT have side-effects by
341;; definition, which means they are safe, as well.
342(define safe-methods
343  (make-parameter '(GET HEAD OPTIONS TRACE)))
344
345;; RFC2616, Section 9.1.1
346(define (safe? obj)
347  (let ((method (if (request? obj) (request-method obj) obj)))
348    (not (not (member method (safe-methods))))))
349
350(define idempotent-methods
351  (make-parameter '(GET HEAD PUT DELETE OPTIONS TRACE)))
352
353;; RFC2616, Section 9.1.2
354(define (idempotent? obj)
355  (let ((method (if (request? obj) (request-method obj) obj)))
356    (not (not (member method (idempotent-methods))))))
357
358(define (keep-alive? obj)
359  (let ((major (if (request? obj) (request-major obj) (response-major obj)))
360        (minor (if (request? obj) (request-minor obj) (response-minor obj)))
361        (con   (header-value 'connection (if (request? obj)
362                                             (request-headers obj)
363                                             (response-headers obj)))))
364   (if (and (= major 1) (> minor 0))
365       (not (eq? con 'close))
366       ;; RFC 2068, section 19.7.1 (see also RFC 2616, section 19.6.2)
367       (eq? con 'keep-alive))))
368
369(define (etag=? a b)
370  (and (not (eq? 'weak (car a)))
371       (eq? (car a) (car b))
372       (string=? (cdr a) (cdr b))))
373
374(define (etag=-weakly? a b)
375  (and (eq? (car a) (car b))
376       (string=? (cdr a) (cdr b))))
377
378(define (etag-matches? etag matchlist)
379  (any (lambda (m) (or (eq? m '*) (etag=? etag m))) matchlist))
380
381(define (etag-matches-weakly? etag matchlist)
382  (any (lambda (m) (or (eq? m '*) (etag=-weakly? etag m))) matchlist))
383
384;;;;;;;;;;;;;;;;;;;;;;;;;
385;;;; Request parsing ;;;;
386;;;;;;;;;;;;;;;;;;;;;;;;;
387
388;; This includes parsers for all RFC-defined headers
389(define header-parsers
390  (make-parameter
391   `((accept . ,(multiple symbol-subparser-ci
392                          `((q . ,quality-subparser))))
393     (accept-charset . ,(multiple symbol-subparser-ci
394                                  `((q . ,quality-subparser))))
395     (accept-encoding . ,(multiple symbol-subparser-ci
396                                   `((q . ,quality-subparser))))
397     (accept-language . ,(multiple symbol-subparser-ci
398                                   `((q . ,quality-subparser))))
399     (accept-ranges . ,(single symbol-subparser-ci))
400     (age . ,(single natnum-subparser))
401     (allow . ,(multiple symbol-subparser))
402     (authorization . ,authorization-parser)
403     (cache-control . ,cache-control-parser)
404     (connection . ,(multiple symbol-subparser-ci))
405     (content-encoding . ,(multiple symbol-subparser-ci))
406     (content-language . ,(multiple symbol-subparser-ci))
407     (content-length . ,(single natnum-subparser))
408     (content-location . ,(single normalized-uri))
409     (content-md5 . ,(single base64-subparser))
410     (content-range . ,(single range-subparser))
411     (content-type . ,(single symbol-subparser-ci
412                              `((charset . ,symbol-subparser-ci))))
413     (date . ,(single http-date-subparser))
414     (etag . ,etag-parser)
415     (expect . ,(single (make-key/value-subparser '())))
416     (expires . ,(single http-date-subparser))
417     (from . ,(multiple mailbox-subparser))
418     (host . ,(single host/port-subparser))
419     (if-match . ,if-match-parser)
420     (if-modified-since . ,(single http-date-subparser))
421     (if-none-match . ,if-match-parser)
422     (if-range . ,if-range-parser)
423     (if-unmodified-since . ,(single http-date-subparser))
424     (last-modified . ,(single http-date-subparser))
425     (location . ,(single normalized-uri))
426     (max-forwards . ,(single natnum-subparser))
427     (pragma . ,pragma-parser)
428     (proxy-authenticate . ,authenticate-parser)
429     (proxy-authorization . ,authorization-parser)
430     (range . ,(multiple range-subparser))
431     (referer . ,(single normalized-uri))
432     (retry-after . ,(single retry-after-subparser))
433     (server . ,software-parser)
434     (te . ,te-parser)
435     (trailer . ,(multiple symbol-subparser-ci))
436     (transfer-encoding . ,(single symbol-subparser-ci))
437     (upgrade . ,(multiple product-subparser))
438     (user-agent . ,software-parser)
439     (vary . ,(multiple symbol-subparser-ci))
440     (via . ,via-parser)
441     (warning . ,warning-parser)
442     (www-authenticate . ,authenticate-parser)
443     ;; RFC 2183
444     (content-disposition . ,(single symbol-subparser-ci
445                                     `((filename . ,filename-subparser)
446                                       (creation-date . ,rfc1123-subparser)
447                                       (modification-date . ,rfc1123-subparser)
448                                       (read-date . ,rfc1123-subparser)
449                                       (size . ,natnum-subparser))))
450     ;; RFC 2109
451     (set-cookie . ,set-cookie-parser)
452     (cookie . ,cookie-parser)
453     ;;
454     ;; TODO: RFC 2965?
455     ;;
456     ;; RFC 6797
457     (strict-transport-security . ,strict-transport-security-parser)
458     ;; Nonstandard but common headers
459     (x-forwarded-for . ,(multiple identity))
460     )))
461
462(define header-parse-error-handler ;; ignore errors
463  (make-parameter (lambda (header-name contents headers exn) headers)))
464
465;; The parser is supposed to return a list of header values for its header
466(define (parse-header name contents)
467  (let* ((default unknown-header-parser)
468         (parser (alist-ref name (header-parsers) eq? default)))
469    (parser contents)))
470
471(define (parse-header-line line headers)
472  (or
473   (and-let* ((colon-idx   (string-index line #\:))
474              (header-name (http-name->symbol (string-take line colon-idx)))
475              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
476     (handle-exceptions
477      exn
478      ((header-parse-error-handler) header-name contents headers exn)
479      (update-header-contents!
480       header-name (parse-header header-name contents) headers)))
481   (signal-http-condition "Bad header line" (list line) 'header-error 'contents line)))
482
483;; XXXX: Bottleneck?
484(define (read-headers port)
485  (if (eof-object? (peek-char port))    ; Yeah, so sue me
486      (make-headers '())
487      (let ((header-limit (http-header-limit))
488            (line-limit (http-line-limit)))
489        (let lp ((c (read-char port))
490                 (ln '())
491                 (headers (make-headers '()))
492                 (hc 0)
493                 (len 0))
494          (cond ((eqv? len line-limit)
495                 (raise-line-limit-exceeded-error
496                  (reverse-list->string ln) line-limit port))
497                ((eof-object? c)
498                 (if (null? ln)
499                     headers
500                     (parse-header-line (reverse-list->string ln) headers)))
501                ;; Only accept CRLF (we're not this strict everywhere...)
502                ((and (eqv? c #\return) (eqv? (peek-char port) #\newline))
503                 (read-char port)       ; Consume and discard NL
504                 (if (null? ln)         ; Nothing came before: end of headers
505                     headers
506                     (let ((pc (peek-char port)))
507                       (if (and (not (eof-object? pc))
508                                (or (eqv? pc #\space) (eqv? pc #\tab)))
509                           ;; If the next line starts with whitespace,
510                           ;; it's a continuation line of the same
511                           ;; header.  See section 2.2 of RFC 2616.
512                           (let skip ((pc (read-char port)) (len len) (ln ln))
513                             (if (and (not (eqv? len line-limit))
514                                      (or (eqv? pc #\space) (eqv? pc #\tab)))
515                                 (skip (read-char port) (add1 len) (cons pc ln))
516                                 (lp pc ln headers hc len)))
517                           (let* ((ln (reverse-list->string ln))
518                                  (headers (parse-header-line ln headers))
519                                  (hc (add1 hc)))
520                             (when (eqv? hc header-limit)
521                               (signal-http-condition
522                                "Max allowed header count exceeded"
523                                (list port)
524                                'header-limit-exceeded
525                                'contents ln
526                                'headers headers
527                                'limit header-limit))
528                             (lp (read-char port) '() headers hc 0))))))
529                ((eqv? c #\")
530                 (let lp2 ((c2 (read-char port))
531                           (ln (cons c ln))
532                           (len len))
533                   (cond ((or (eqv? 0 len) (eof-object? c2))
534                          (lp c2 ln headers hc len))
535                         ((eqv? c2 #\")
536                          (lp (read-char port) (cons c2 ln)
537                              headers hc (add1 len)))
538                         ((eqv? c2 #\\)
539                          (let ((c3 (read-char port))
540                                (len len))
541                            (if (or (eof-object? c3) (eqv? 0 len))
542                                (lp c3 (cons c2 ln) headers hc len)
543                                (lp2 (read-char port)
544                                     (cons c3 (cons c2 ln))
545                                     (add1 len)))))
546                         (else
547                          (lp2 (read-char port) (cons c2 ln) (add1 len))))))
548                (else
549                 (lp (read-char port) (cons c ln) headers hc (add1 len))))))))
550
551(define (signal-http-condition msg args type . more-info)
552  (signal (make-composite-condition
553           (make-property-condition 'http)
554           (apply make-property-condition type more-info)
555           (make-property-condition 'exn 'message msg 'arguments args))))
556
557(defstruct request
558  (method 'GET) uri (major 1) (minor 1) (headers (make-headers '())) port)
559
560;; Perhaps we should have header parsers indexed by version or
561;; something like that, so you can define the maximum version. Useful
562;; for when expecting a response. Then we group request/response parsers
563;; together, as with request/response unparsers.
564(define http-0.9-request-parser
565  (let ((req (irregex '(seq (w/nocase "GET") (+ space) (=> uri (* any))))))
566    (lambda (line in)
567      (and-let* ((m (irregex-match req line))
568                 (uri (normalized-uri (irregex-match-substring m 'uri))))
569        (make-request method: 'GET uri: uri
570                      major: 0 minor: 9 port: in)))))
571
572;; Might want to reuse this elsewhere
573(define token-sre '(+ (~ "()<>@,;:\\\"/[]?={}\t ")))
574
575;; XXX This actually parses anything >= HTTP/1.0
576(define http-1.x-request-parser
577  (let ((req (irregex `(seq (=> method ,token-sre) (+ space)
578                            (=> uri (+ (~ blank))) ; uri-common handles details
579                            (+ space) (w/nocase "HTTP/")
580                            (=> major (+ digit)) "." (=> minor (+ digit))))))
581    (lambda (line in)
582      (and-let* ((m (irregex-match req line))
583                 (uri-string (irregex-match-substring m 'uri))
584                 (major (string->number (irregex-match-substring m 'major)))
585                 (minor (string->number (irregex-match-substring m 'minor)))
586                 (method (string->http-method (irregex-match-substring m 'method)))
587                 (headers (read-headers in)))
588        (let* ((wildcard (string=? uri-string "*"))
589               (uri (and (not wildcard) (normalized-uri uri-string))))
590          ;; HTTP/1.1 allows several "things" as "URI" (RFC2616, 5.1.2):
591          ;; Request-URI = "*" | absoluteURI | abs_path | authority
592          ;;
593          ;; HTTP/1.0, URIs are more limited (RFC1945, 5.1.2):
594          ;; Request-URI = absoluteURI | abs_path
595          ;;
596          ;; Currently, a plain authority is not accepted.  This would
597          ;; require deep changes in the representation of request
598          ;; objects.  It is only used in CONNECT requests, so
599          ;; currently not much of a problem.  If we want to support
600          ;; this, we'd need a separate object type and expose a
601          ;; parser from uri-generic/uri-common for just authority.
602          (and (or (and wildcard (or (> major 1) (>= minor 1)))
603                   (and uri (or (absolute-uri? uri)
604                                (and (uri-path-absolute? uri)
605                                     (not (uri-host uri))))))
606               (make-request method: method uri: uri
607                             major: major minor: minor
608                             headers: headers
609                             port: in)))))))
610
611(define request-parsers   ; order matters here
612  (make-parameter (list http-1.x-request-parser)))
613
614(define (read-request inport)
615  (let ((line (safe-read-line inport)))
616    (and (not (eof-object? line))
617         ;; Try each parser in turn to process the request-line.
618         ;; A parser returns either #f or a request object
619         (let loop ((parsers (request-parsers)))
620           (if (null? parsers)
621               (signal-http-condition "Unknown protocol line" (list line)
622                                      'unknown-protocol-line 'line line)
623               (or ((car parsers) line inport) (loop (cdr parsers))))))))
624
625;;;;;;;;;;;;;;;;;;;;;;;;;;;
626;;;; Request unparsing ;;;;
627;;;;;;;;;;;;;;;;;;;;;;;;;;;
628
629(define header-unparsers
630  (make-parameter
631   `((content-disposition . ,content-disposition-unparser)
632     (date . ,rfc1123-unparser)
633     (etag . ,etag-unparser)
634     (expires . ,rfc1123-unparser)
635     (host . ,host/port-unparser)
636     (if-match . ,if-match-unparser)
637     (if-modified-since . ,rfc1123-unparser)
638     (if-none-match . ,if-match-unparser)
639     (if-unmodified-since . ,rfc1123-unparser)
640     (last-modified . ,rfc1123-unparser)
641     (user-agent . ,software-unparser)
642     (server . ,software-unparser)
643     (upgrade . ,product-unparser)
644     (cookie . ,cookie-unparser)
645     (set-cookie . ,set-cookie-unparser)
646     (authorization . ,authorization-unparser)
647     (www-authenticate . ,authenticate-unparser)
648     (proxy-authorization . ,authorization-unparser)
649     (proxy-authenticate . ,authenticate-unparser)
650     (via . ,via-unparser)
651     ;; RFC 6797
652     (strict-transport-security . ,strict-transport-security-unparser))))
653
654(define (unparse-header header-name header-value)
655  (cond ((assq header-name (header-unparsers))
656         => (lambda (unparser) ((cdr unparser) header-value)))
657        (else (default-header-unparser header-value))))
658
659(define (unparse-headers headers out)
660  (let ((unparsers (header-unparsers))) ; Don't access parameter for each header
661    (for-each
662     (lambda (h)
663       (let* ((name (car h))
664              (name-s (symbol->http-name name))
665              (contents (cdr h))
666              (unparse (cond ((assq name unparsers) => cdr) ; inlined for perf
667                             (else default-header-unparser))))
668         (for-each (lambda (value)
669                     ;; Verify there's no \r\n or \r or \n in value?
670                     (display (string-append name-s ": " value "\r\n") out))
671                   (unparse contents))))
672     (headers-v headers))))
673
674;; Use string-append and display rather than fprintf so the line gets
675;; written in one burst.  This supposedly avoids a strange race
676;; condition, see #800.  We use string-append instead of sprintf for
677;; performance reasons.  This is not exported, and our callers compare
678;; request-major and request-minor so we can assume they're numbers.
679(define (write-request-line request)
680  (let ((uri (request-uri request)))
681    (display (string-append
682              (http-method->string (request-method request))
683              " " (if uri (uri->string uri) "*") " HTTP/"
684              (number->string (request-major request)) "."
685              (number->string (request-minor request)) "\r\n")
686             (request-port request))))
687
688(define (http-0.9-request-unparser request)
689  (display (string-append "GET " (uri->string (request-uri request)) "\r\n")
690           (request-port request))
691  request)
692
693(define (http-1.0-request-unparser request)
694  (and-let* (((= (request-major request) 1))
695             ((= (request-minor request) 0))
696             (o (request-port request)))
697    (write-request-line request)
698    (unparse-headers (request-headers request) o)
699    (display "\r\n" o)
700    request))
701
702;; XXX This actually unparses anything >= HTTP/1.1
703(define (http-1.x-request-unparser request)
704  (and-let* (((or (> (request-major request) 1)
705                  (and (= (request-major request) 1)
706                       (> (request-minor request) 0))))
707             (o (request-port request)))
708    (write-request-line request)
709    (unparse-headers (request-headers request) o)
710    (display "\r\n" o)
711    (if (memq 'chunked (header-values 'transfer-encoding
712                                      (request-headers request)))
713        (update-request request
714                        port: (chunked-output-port (request-port request)))
715        request)))
716
717(define request-unparsers  ; order matters here
718  (make-parameter (list http-1.x-request-unparser http-1.0-request-unparser)))
719
720(define (write-request request)
721  ;; Try each unparser in turn to write the request-line.
722  ;; An unparser returns either #f or a new request object.
723  (let loop ((unparsers (request-unparsers)))
724    (if (null? unparsers)
725        (let ((major (request-major request))
726              (minor (request-minor request)))
727         (signal-http-condition "Unknown protocol" (list (conc major "." minor))
728                                'unknown-protocol 'major major 'minor minor))
729        (or ((car unparsers) request) (loop (cdr unparsers))))))
730
731;; Required for chunked requests.  This is a bit of a hack!
732(define (finish-request-body request)
733  (when (and (memq 'chunked (header-values 'transfer-encoding
734                                           (request-headers request)))
735             (eq? (##sys#slot (request-port request) 10) 'chunked-output-port))
736    (display "0\r\n\r\n" (##sys#slot (request-port request) 11)))
737  request)
738
739;;;;;;;;;;;;;;;;;;;;;;;;;;;;
740;;;; Response unparsing ;;;;
741;;;;;;;;;;;;;;;;;;;;;;;;;;;;
742
743(defstruct response
744  (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port)
745
746(define make-response
747  (let ((old-make-response make-response))
748    (lambda (#!rest args #!key status code reason)
749      (let ((resp (apply old-make-response args)))
750        (when (and status (not code) (not reason))
751          (response-status-set! resp status))
752        resp))))
753
754(define update-response
755  (let ((old-update-response update-response))
756    (lambda (resp #!rest args #!key status code reason)
757      (let ((resp (apply old-update-response resp args)))
758        (when (and status (not code) (not reason))
759          (response-status-set! resp status))
760        resp))))
761
762(define (response-status-set! resp status)
763  (receive (code reason) (http-status->code&reason status)
764    (response-code-set! resp code)
765    (response-reason-set! resp reason)
766    resp))
767
768(define (response-class obj)
769  (let ((code (if (response? obj) (response-code obj) obj)))
770    (- code (modulo code 100))))
771
772(define (response-status obj)
773  (let* ((c (if (response? obj) (response-code obj) obj))
774         (s (find (lambda (x) (= (cadr x) c)) (http-status-codes))))
775    (if s
776        (car s)
777        (signal-http-condition "Unknown status code" (list c)
778                               'unknown-code 'code c))))
779
780(define (http-status->code&reason status)
781  (let ((s (alist-ref status (http-status-codes))))
782    (unless s
783      (signal-http-condition "Unknown response status symbol" (list status)
784                             'unknown-status 'status status))
785    (values (car s) (cdr s))))
786
787;; List of HTTP status codes based on:
788;; http://www.iana.org/assignments/http-status-codes/http-status-codes.xml
789(define http-status-codes
790  (make-parameter 
791   `((continue . (100 . "Continue"))
792     (switching-protocols . (101 . "Switching Protocols"))
793     (processing . (102 . "Processing"))
794     (ok . (200 . "OK"))
795     (created . (201 . "Created"))
796     (accepted . (202 . "Accepted"))
797     (non-authoritative-information . (203 . "Non-Authoritative Information"))
798     (no-content . (204 . "No Content"))
799     (reset-content . (205 . "Reset Content"))
800     (partial-content . (206 . "Partial Content"))
801     (multi-status . (207 . "Multi-Status"))
802     (already-reported . (208 . "Already Reported"))
803     (im-used . (226 . "IM Used"))
804     (multiple-choices . (300 . "Multiple Choices"))
805     (moved-permanently . (301 . "Moved Permanently"))
806     (found . (302 . "Found"))
807     (see-other . (303 . "See Other"))
808     (not-modified . (304 . "Not Modified"))
809     (use-proxy . (305 . "Use Proxy"))
810     (temporary-redirect . (307 . "Temporary Redirect"))
811     (bad-request . (400 . "Bad Request"))
812     (unauthorized . (401 . "Unauthorized"))
813     (payment-required . (402 . "Payment Required"))
814     (forbidden . (403 . "Forbidden"))
815     (not-found . (404 . "Not Found"))
816     (method-not-allowed . (405 . "Method Not Allowed"))
817     (not-acceptable . (406 . "Not Acceptable"))
818     (proxy-authentication-required . (407 . "Proxy Authentication Required"))
819     (request-time-out . (408 . "Request Time-out"))
820     (conflict . (409 . "Conflict"))
821     (gone . (410 . "Gone"))
822     (length-required . (411 . "Length Required"))
823     (precondition-failed . (412 . "Precondition Failed"))
824     (request-entity-too-large . (413 . "Request Entity Too Large"))
825     (request-uri-too-large . (414 . "Request-URI Too Large"))
826     (unsupported-media-type . (415 . "Unsupported Media Type"))
827     (requested-range-not-satisfiable . (416 . "Requested Range Not Satisfiable"))
828     (expectation-failed . (417 . "Expectation Failed"))
829     (unprocessable-entity . (422 . "Unprocessable Entity"))
830     (locked . (423 . "Locked"))
831     (failed-dependency . (424 . "Failed Dependency"))
832     (upgrade-required . (426 . "Upgrade Required"))
833     (precondition-required . (428 . "Precondition Required"))
834     (too-many-requests . (429 . "Too Many Requests"))
835     (request-header-fields-too-large . (431 . "Request Header Fields Too Large"))
836     (internal-server-error . (500 . "Internal Server Error"))
837     (not-implemented . (501 . "Not Implemented"))
838     (bad-gateway . (502 . "Bad Gateway"))
839     (service-unavailable . (503 . "Service Unavailable"))
840     (gateway-time-out . (504 . "Gateway Time-out"))
841     (http-version-not-supported . (505 . "HTTP Version Not Supported"))
842     (insufficient-storage . (507 . "Insufficient Storage"))
843     (loop-detected . (508 . "Loop Detected"))
844     (not-extended . (510 . "Not Extended"))
845     (network-authentication-required . (511 . "Network Authentication Required")))))
846
847(define (http-0.9-response-unparser response)
848  response) ;; The response-body will just follow
849
850;; See notes at write-request-line
851(define (write-response-line response)
852  (display (string-append
853            "HTTP/"
854            (number->string (response-major response)) "."
855            (number->string (response-minor response)) " "
856            (->string (response-code response)) " "
857            (->string (response-reason response)) "\r\n")
858           (response-port response)))
859
860(define (http-1.0-response-unparser response)
861  (and-let* (((= (response-major response) 1))
862             ((= (response-minor response) 0))
863             (o (response-port response)))
864    (write-response-line response)
865    (unparse-headers (response-headers response) o)
866    (display "\r\n" o)
867    response))
868
869;; XXX This actually unparses anything >= HTTP/1.1
870(define (http-1.x-response-unparser response)
871  (and-let* (((or (> (response-major response) 1)
872                  (and (= (response-major response) 1)
873                       (> (response-minor response) 0))))
874             (o (response-port response)))
875    (write-response-line response)
876    (unparse-headers (response-headers response) o)
877    (display "\r\n" o)
878    (if (memq 'chunked (header-values 'transfer-encoding
879                                      (response-headers response)))
880        (update-response response
881                         port: (chunked-output-port (response-port response)))
882        response)))
883
884(define response-unparsers
885  (make-parameter (list http-1.x-response-unparser http-1.0-response-unparser)))
886
887(define (write-response response)
888  ;; Try each unparser in turn to write the response-line.
889  ;; An unparser returns either #f or a new response object.
890  (let loop ((unparsers (response-unparsers)))
891    (if (null? unparsers)
892        (let ((major (response-major response))
893              (minor (response-minor response)))
894          (signal-http-condition "Unknown protocol" (list (conc major "." minor))
895                                 'unknown-protocol 'major major 'minor minor))
896        (or ((car unparsers) response) (loop (cdr unparsers))))))
897
898;; Required for chunked requests.  This is a bit of a hack!
899(define (finish-response-body response)
900  (when (and (memq 'chunked (header-values 'transfer-encoding
901                                           (response-headers response)))
902             (eq? (##sys#slot (response-port response) 10) 'chunked-output-port))
903    (display "0\r\n\r\n" (##sys#slot (response-port response) 11)))
904  response)
905
906;;;;;;;;;;;;;;;;;;;;;;;;;;
907;;;; Response parsing ;;;;
908;;;;;;;;;;;;;;;;;;;;;;;;;;
909
910(define http-1.x-response-parser
911  (let ((resp (irregex '(seq (w/nocase "HTTP/")
912                             (=> major (+ digit)) "." (=> minor (+ digit))
913                             ;; Could use '(= 3 digit) for status-code, but
914                             ;; that's currently not compilable
915                             (+ space) (=> status-code digit digit digit)
916                             (+ space) (=> reason-phrase (* nonl))))))
917    (lambda (line in)
918      (and-let* ((m (irregex-match resp line))
919                 (code (string->number (irregex-match-substring m 'status-code)))
920                 (major (string->number (irregex-match-substring m 'major)))
921                 (minor (string->number (irregex-match-substring m 'minor)))
922                 ((or (> major 1) (and (= major 1) (> minor 0))))
923                 (reason (irregex-match-substring m 'reason-phrase))
924                 (h (read-headers in))
925                 (port (if (memq 'chunked (header-values 'transfer-encoding h))
926                           (chunked-input-port in)
927                           in)))
928        (make-response code: code reason: reason
929                       major: major minor: minor
930                       headers: h
931                       port: port)))))
932
933(define http-1.0-response-parser
934  (let ((resp (irregex '(seq (w/nocase "HTTP/1.0")
935                             ;; Could use '(= 3 digit) for status-code, but
936                             ;; that's currently not compilable
937                             (+ space) (=> status-code digit digit digit)
938                             (+ space) (=> reason-phrase (* nonl))))))
939    (lambda (line in)
940      (and-let* ((m (irregex-match resp line))
941                 (code (string->number (irregex-match-substring m 'status-code)))
942                 (reason (irregex-match-substring m 'reason-phrase))
943                 (h (read-headers in)))
944        ;; HTTP/1.0 has no chunking
945        (make-response code: code reason: reason
946                       major: 1 minor: 0
947                       headers: h
948                       port: in)))))
949
950;; You can't "detect" a 0.9 response, because there is no response line.
951;; It will simply output the body directly, so we will just assume that
952;; if we can't recognise the output string, we just got a 0.9 response.
953(define (http-0.9-response-parser line in)
954  (make-response code: 200 reason: "OK"
955                 major: 0 minor: 9
956                 ;; XXX This is wrong, it re-inserts \r\n, while it may have
957                 ;; been a \n only. To work around this, we'd have to write
958                 ;; a custom (safe-)read-line procedure.
959                 ;; However, it does not matter much because HTTP 0.9 is only
960                 ;; defined to ever return text/html, no binary or any other
961                 ;; content type.
962                 port: (call-with-input-string (string-append line "\r\n")
963                         (lambda (str)
964                           (make-concatenated-port str in)))))
965
966(define response-parsers ;; order matters here
967  (make-parameter (list http-1.x-response-parser http-1.0-response-parser)))
968
969(define (read-response inport)
970  (let ((line (safe-read-line inport)))
971    (and (not (eof-object? line))
972         (let loop ((parsers (response-parsers)))
973           (if (null? parsers)
974               (signal-http-condition "Unknown protocol line" (list line)
975                                      'unknown-protocol-line 'line line)
976               (or ((car parsers) line inport) (loop (cdr parsers))))))))
977
978)
Note: See TracBrowser for help on using the repository browser.