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

Last change on this file since 33320 was 33320, checked in by sjamaan, 5 years ago

Goddamn spammers. Rot in hell why don't you?

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