X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/ecfb7167cbc239a4b4f11cb8287e8116c2760cff..23cf330c86a56b12525af0fea8ce7da0e0981e45:/module/web/http.scm diff --git a/module/web/http.scm b/module/web/http.scm index 8298505d0..21d2964b4 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1,6 +1,6 @@ ;;; HTTP messages -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -33,13 +33,16 @@ #:use-module ((srfi srfi-1) #:select (append-map! map!)) #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) - #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:use-module (ice-9 q) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) #:use-module (web uri) #:export (string->header header->string declare-header! + declare-opaque-header! known-header? header-parser header-validator @@ -60,18 +63,17 @@ read-request-line write-request-line read-response-line - write-response-line)) + write-response-line + make-chunked-input-port + make-chunked-output-port -;;; TODO -;;; -;;; Look at quality lists with more insight. -;;; Think about `accept' a bit more. -;;; + http-proxy-port? + set-http-proxy-port?!)) (define (string->header name) - "Parse @var{name} to a symbolic header name." + "Parse NAME to a symbolic header name." (string->symbol (string-downcase name))) (define-record-type @@ -94,12 +96,7 @@ validator writer #:key multiple?) - "Define a parser, validator, and writer for the HTTP header, @var{name}. - -@var{parser} should be a procedure that takes a string and returns a -Scheme value. @var{validator} is a predicate for whether the given -Scheme value is valid for this header. @var{writer} takes a value and a -port, and writes the value to the port." + "Declare a parser, validator, and writer for a given header." (if (and (string? name) parser validator writer) (let ((decl (make-header-decl name parser validator writer multiple?))) (hashq-set! *declared-headers* (string->header name) decl) @@ -107,34 +104,40 @@ port, and writes the value to the port." (error "bad header decl" name parser validator writer multiple?))) (define (header->string sym) - "Return the string form for the header named @var{sym}." + "Return the string form for the header named SYM." (let ((decl (lookup-header-decl sym))) (if decl (header-decl-name decl) (string-titlecase (symbol->string sym))))) (define (known-header? sym) - "Return @code{#t} if there are parsers and writers registered for this -header, otherwise @code{#f}." + "Return ‘#t’ iff SYM is a known header, with associated +parsers and serialization procedures." (and (lookup-header-decl sym) #t)) (define (header-parser sym) - "Returns a procedure to parse values for the given header." + "Return the value parser for headers named SYM. The result is a +procedure that takes one argument, a string, and returns the parsed +value. If the header isn't known to Guile, a default parser is returned +that passes through the string unchanged." (let ((decl (lookup-header-decl sym))) (if decl (header-decl-parser decl) (lambda (x) x)))) (define (header-validator sym) - "Returns a procedure to validate values for the given header." + "Return a predicate which returns ‘#t’ if the given value is valid +for headers named SYM. The default validator for unknown headers +is ‘string?’." (let ((decl (lookup-header-decl sym))) (if decl (header-decl-validator decl) string?))) (define (header-writer sym) - "Returns a procedure to write values for the given header to a given -port." + "Return a procedure that writes values for headers named SYM to a +port. The resulting procedure takes two arguments: a value and a port. +The default writer is ‘display’." (let ((decl (lookup-header-decl sym))) (if decl (header-decl-writer decl) @@ -167,7 +170,7 @@ port." (define *eof* (call-with-input-string "" read)) (define (read-header port) - "Reads one HTTP header from @var{port}. Returns two values: the header + "Read one HTTP header from PORT. Return two values: the header name and the parsed Scheme value. May raise an exception if the header was known but the value was invalid. @@ -186,35 +189,31 @@ body was reached (i.e., a blank line)." sym (read-continuation-line port - (string-trim-both line char-whitespace? (1+ delim))))))))) + (string-trim-both line char-set:whitespace (1+ delim))))))))) (define (parse-header sym val) - "Parse @var{val}, a string, with the parser registered for the header -named @var{sym}. - -Returns the parsed value. If a parser was not found, the value is -returned as a string." + "Parse VAL, a string, with the parser registered for the header +named SYM. Returns the parsed value." ((header-parser sym) val)) (define (valid-header? sym val) - "Returns a true value iff @var{val} is a valid Scheme value for the -header with name @var{sym}." + "Returns a true value iff VAL is a valid Scheme value for the +header with name SYM." (if (symbol? sym) ((header-validator sym) val) (error "header name not a symbol" sym))) (define (write-header sym val port) - "Writes the given header name and value to @var{port}. If @var{sym} -is a known header, uses the specific writer registered for that header. -Otherwise the value is written using @var{display}." + "Write the given header name and value to PORT, using the writer +from ‘header-writer’." (display (header->string sym) port) (display ": " port) ((header-writer sym) val port) (display "\r\n" port)) (define (read-headers port) - "Read an HTTP message from @var{port}, returning the headers as an -ordered alist." + "Read the headers of an HTTP message from PORT, returning them +as an ordered alist." (let lp ((headers '())) (call-with-values (lambda () (read-header port)) (lambda (k v) @@ -223,8 +222,8 @@ ordered alist." (lp (acons k v headers))))))) (define (write-headers headers port) - "Write the given header alist to @var{port}. Doesn't write the final -\\r\\n, as the user might want to add another header." + "Write the given header alist to PORT. Doesn't write the final +‘\\r\\n’, as the user might want to add another header." (let lp ((headers headers)) (if (pair? headers) (begin @@ -241,7 +240,22 @@ ordered alist." (define (bad-header sym val) (throw 'bad-header sym val)) (define (bad-header-component sym val) - (throw 'bad-header sym val)) + (throw 'bad-header-component sym val)) + +(define (bad-header-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header: ~a\n" (header->string sym) val)) + (_ (default-printer))) + args)) +(define (bad-header-component-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header component: ~a\n" sym val)) + (_ (default-printer))) + args)) +(set-exception-printer! 'bad-header bad-header-printer) +(set-exception-printer! 'bad-header-component bad-header-component-printer) (define (parse-opaque-string str) str) @@ -278,7 +292,7 @@ ordered alist." (let lp ((i start)) (if (< i end) (let* ((idx (string-index str delim i end)) - (tok (string-trim-both str char-whitespace? i (or idx end)))) + (tok (string-trim-both str char-set:whitespace i (or idx end)))) (cons tok (split-and-trim str delim (if idx (1+ idx) end) end))) '()))) @@ -421,13 +435,13 @@ ordered alist." (cond ((string-rindex part #\;) => (lambda (idx) - (let ((qpart (string-trim-both part char-whitespace? (1+ idx)))) + (let ((qpart (string-trim-both part char-set:whitespace (1+ idx)))) (if (string-prefix? "q=" qpart) (cons (parse-quality qpart 2) - (string-trim-both part char-whitespace? 0 idx)) + (string-trim-both part char-set:whitespace 0 idx)) (bad-header-component 'quality qpart))))) (else - (cons 1000 (string-trim-both part char-whitespace?))))) + (cons 1000 (string-trim-both part char-set:whitespace))))) (string-split str #\,))) (define (validate-quality-list l) @@ -471,7 +485,7 @@ ordered alist." val) (define (default-val-validator k val) - (string? val)) + (or (not val) (string? val))) (define (default-val-writer k val port) (if (or (string-index val #\;) @@ -519,9 +533,9 @@ ordered alist." ((pair? elt) (let ((k (car elt)) (v (cdr elt))) - (and (or (string? k) (symbol? k)) + (and (symbol? k) (valid? k v)))) - ((or (string? elt) (symbol? elt)) + ((symbol? elt) (valid? elt #f)) (else #f))))) @@ -542,15 +556,15 @@ ordered alist." ;; param-component = token [ "=" (token | quoted-string) ] \ ;; *(";" token [ "=" (token | quoted-string) ]) ;; +(define param-delimiters (char-set #\, #\; #\=)) +(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;)) (define* (parse-param-component str #:optional (val-parser default-val-parser) (start 0) (end (string-length str))) (let lp ((i start) (out '())) (if (not (< i end)) (values (reverse! out) end) - (let ((delim (string-index str - (lambda (c) (memq c '(#\, #\; #\=))) - i))) + (let ((delim (string-index str param-delimiters i))) (let ((k (string->symbol (substring str i (trim-whitespace str i (or delim end))))) (delimc (and delim (string-ref str delim)))) @@ -562,13 +576,8 @@ ordered alist." (if (and (< i end) (eqv? (string-ref str i) #\")) (parse-qstring str i end #:incremental? #t) (let ((delim - (or (string-index - str - (lambda (c) - (or (eqv? c #\;) - (eqv? c #\,) - (char-whitespace? c))) - i end) + (or (string-index str param-value-delimiters + i end) end))) (values (substring str i delim) delim))))) @@ -612,7 +621,7 @@ ordered alist." (valid? default-val-validator)) (list-of? list (lambda (elt) - (key-value-list? list valid?)))) + (key-value-list? elt valid?)))) (define* (write-param-list list port #:optional (val-writer default-val-writer)) @@ -622,22 +631,220 @@ ordered alist." (write-key-value-list item port val-writer ";")) ",")) +(define-syntax string-match? + (lambda (x) + (syntax-case x () + ((_ str pat) (string? (syntax->datum #'pat)) + (let ((p (syntax->datum #'pat))) + #`(let ((s str)) + (and + (= (string-length s) #,(string-length p)) + #,@(let lp ((i 0) (tests '())) + (if (< i (string-length p)) + (let ((c (string-ref p i))) + (lp (1+ i) + (case c + ((#\.) ; Whatever. + tests) + ((#\d) ; Digit. + (cons #`(char-numeric? (string-ref s #,i)) + tests)) + ((#\a) ; Alphabetic. + (cons #`(char-alphabetic? (string-ref s #,i)) + tests)) + (else ; Literal. + (cons #`(eqv? (string-ref s #,i) #,c) + tests))))) + tests))))))))) + +;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" +;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec" + +(define (parse-month str start end) + (define (bad) + (bad-header-component 'month (substring str start end))) + (if (not (= (- end start) 3)) + (bad) + (let ((a (string-ref str (+ start 0))) + (b (string-ref str (+ start 1))) + (c (string-ref str (+ start 2)))) + (case a + ((#\J) + (case b + ((#\a) (case c ((#\n) 1) (else (bad)))) + ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad)))) + (else (bad)))) + ((#\F) + (case b + ((#\e) (case c ((#\b) 2) (else (bad)))) + (else (bad)))) + ((#\M) + (case b + ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad)))) + (else (bad)))) + ((#\A) + (case b + ((#\p) (case c ((#\r) 4) (else (bad)))) + ((#\u) (case c ((#\g) 8) (else (bad)))) + (else (bad)))) + ((#\S) + (case b + ((#\e) (case c ((#\p) 9) (else (bad)))) + (else (bad)))) + ((#\O) + (case b + ((#\c) (case c ((#\t) 10) (else (bad)))) + (else (bad)))) + ((#\N) + (case b + ((#\o) (case c ((#\v) 11) (else (bad)))) + (else (bad)))) + ((#\D) + (case b + ((#\e) (case c ((#\c) 12) (else (bad)))) + (else (bad)))) + (else (bad)))))) + +;; "GMT" | "+" 4DIGIT | "-" 4DIGIT +;; +;; RFC 2616 requires date values to use "GMT", but recommends accepting +;; the others as they are commonly generated by e.g. RFC 822 sources. +(define (parse-zone-offset str start) + (let ((s (substring str start))) + (define (bad) + (bad-header-component 'zone-offset s)) + (cond + ((string=? s "GMT") + 0) + ((string-match? s ".dddd") + (let ((sign (case (string-ref s 0) + ((#\+) +1) + ((#\-) -1) + (else (bad)))) + (hours (parse-non-negative-integer s 1 3)) + (minutes (parse-non-negative-integer s 3 5))) + (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich + (else (bad))))) + +;; RFC 822, updated by RFC 1123 +;; +;; Sun, 06 Nov 1994 08:49:37 GMT +;; 01234567890123456789012345678 +;; 0 1 2 +(define (parse-rfc-822-date str space zone-offset) + ;; We could verify the day of the week but we don't. + (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 17 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 16 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + (else + (bad-header 'date str) ; prevent tail call + #f))) + +;; RFC 850, updated by RFC 1036 +;; Sunday, 06-Nov-94 08:49:37 GMT +;; 0123456789012345678901 +;; 0 1 2 +(define (parse-rfc-850-date str comma space zone-offset) + ;; We could verify the day of the week but we don't. + (let ((tail (substring str (1+ comma) space))) + (if (not (string-match? tail " dd-aaa-dd dd:dd:dd")) + (bad-header 'date str)) + (let ((date (parse-non-negative-integer tail 1 3)) + (month (parse-month tail 4 7)) + (year (parse-non-negative-integer tail 8 10)) + (hour (parse-non-negative-integer tail 11 13)) + (minute (parse-non-negative-integer tail 14 16)) + (second (parse-non-negative-integer tail 17 19))) + (make-date 0 second minute hour date month + (let* ((now (date-year (current-date))) + (then (+ now year (- (modulo now 100))))) + (cond ((< (+ then 50) now) (+ then 100)) + ((< (+ now 50) then) (- then 100)) + (else then))) + zone-offset)))) + +;; ANSI C's asctime() format +;; Sun Nov 6 08:49:37 1994 +;; 012345678901234567890123 +;; 0 1 2 +(define (parse-asctime-date str) + (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd")) + (bad-header 'date str)) + (let ((date (parse-non-negative-integer + str + (if (eqv? (string-ref str 8) #\space) 9 8) + 10)) + (month (parse-month str 4 7)) + (year (parse-non-negative-integer str 20 24)) + (hour (parse-non-negative-integer str 11 13)) + (minute (parse-non-negative-integer str 14 16)) + (second (parse-non-negative-integer str 17 19))) + (make-date 0 second minute hour date month year 0))) + +;; Convert all date values to GMT time zone, as per RFC 2616 appendix C. +(define (normalize-date date) + (if (zero? (date-zone-offset date)) + date + (time-utc->date (date->time-utc date) 0))) + (define (parse-date str) - ;; Unfortunately, there is no way to make string->date parse out the - ;; "GMT" bit, so we play string games to append a format it will - ;; understand (the +0000 bit). - (string->date - (if (string-suffix? " GMT" str) - (string-append (substring str 0 (- (string-length str) 4)) - " +0000") - (bad-header-component 'date str)) - "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (let* ((space (string-rindex str #\space)) + (zone-offset (and space (false-if-exception + (parse-zone-offset str (1+ space)))))) + (normalize-date + (if zone-offset + (let ((comma (string-index str #\,))) + (cond ((not comma) (bad-header 'date str)) + ((= comma 3) (parse-rfc-822-date str space zone-offset)) + (else (parse-rfc-850-date str comma space zone-offset)))) + (parse-asctime-date str))))) (define (write-date date port) - (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port)) - -(define (write-uri uri port) - (display (uri->string uri) port)) + (define (display-digits n digits port) + (define zero (char->integer #\0)) + (let lp ((tens (expt 10 (1- digits)))) + (if (> tens 0) + (begin + (display (integer->char (+ zero (modulo (truncate/ n tens) 10))) + port) + (lp (floor/ tens 10)))))) + (let ((date (if (zero? (date-zone-offset date)) + date + (time-tai->date (date->time-tai date) 0)))) + (display (case (date-week-day date) + ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") + ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") + ((6) "Sat, ") (else (error "bad date" date))) + port) + (display-digits (date-day date) 2 port) + (display (case (date-month date) + ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") + ((4) " Apr ") ((5) " May ") ((6) " Jun ") + ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") + ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") + (else (error "bad date" date))) + port) + (display-digits (date-year date) 4 port) + (display #\space port) + (display-digits (date-hour date) 2 port) + (display #\: port) + (display-digits (date-minute date) 2 port) + (display #\: port) + (display-digits (date-second date) 2 port) + (display " GMT" port))) (define (parse-entity-tag val) (if (string-prefix? "W/" val) @@ -687,7 +894,7 @@ ordered alist." (define* (parse-credentials str #:optional (val-parser default-val-parser) (start 0) (end (string-length str))) (let* ((start (skip-whitespace str start end)) - (delim (or (string-index str char-whitespace? start end) end))) + (delim (or (string-index str char-set:whitespace start end) end))) (if (= start end) (bad-header-component 'authorization str)) (let ((scheme (string->symbol @@ -702,7 +909,10 @@ ordered alist." (cons scheme (parse-key-value-list str default-val-parser delim end))))))) (define (validate-credentials val) - (and (pair? val) (symbol? (car val)) (key-value-list? (cdr val)))) + (and (pair? val) (symbol? (car val)) + (case (car val) + ((basic) (string? (cdr val))) + (else (key-value-list? (cdr val)))))) (define (write-credentials val port) (display (car val) port) @@ -795,9 +1005,9 @@ ordered alist." (define *known-versions* '()) (define* (parse-http-version str #:optional (start 0) (end (string-length str))) - "Parse an HTTP version from @var{str}, returning it as a major-minor -pair. For example, @code{HTTP/1.1} parses as the pair of integers, -@code{(1 . 1)}." + "Parse an HTTP version from STR, returning it as a major–minor +pair. For example, ‘HTTP/1.1’ parses as the pair of integers, +‘(1 . 1)’." (or (let lp ((known *known-versions*)) (and (pair? known) (if (string= str (caar known) start end) @@ -812,7 +1022,7 @@ pair. For example, @code{HTTP/1.1} parses as the pair of integers, (bad-header-component 'http-version (substring str start end)))))) (define (write-http-version val port) - "Write the given major-minor version pair to @var{port}." + "Write the given major-minor version pair to PORT." (display "HTTP/" port) (display (car val) port) (display #\. port) @@ -833,8 +1043,8 @@ pair. For example, @code{HTTP/1.1} parses as the pair of integers, ;; ourselves the trouble of that case, and disallow the CONNECT method. ;; (define* (parse-http-method str #:optional (start 0) (end (string-length str))) - "Parse an HTTP method from @var{str}. The result is an upper-case -symbol, like @code{GET}." + "Parse an HTTP method from STR. The result is an upper-case +symbol, like ‘GET’." (cond ((string= str "GET" start end) 'GET) ((string= str "HEAD" start end) 'HEAD) @@ -866,11 +1076,11 @@ not have to have a scheme or host name. The result is a URI object." (bad-request "Invalid URI: ~a" (substring str start end)))))) (define (read-request-line port) - "Read the first line of an HTTP request from @var{port}, returning + "Read the first line of an HTTP request from PORT, returning three values: the method, the URI, and the version." (let* ((line (read-line* port)) - (d0 (string-index line char-whitespace?)) ; "delimiter zero" - (d1 (string-rindex line char-whitespace?))) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (string-rindex line char-set:whitespace))) (if (and d0 d1 (< d0 d1)) (values (parse-http-method line 0 d0) (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) @@ -907,31 +1117,57 @@ three values: the method, the URI, and the version." (display (uri-query uri) port)))) (define (write-request-line method uri version port) - "Write the first line of an HTTP request to @var{port}." + "Write the first line of an HTTP request to PORT." (display method port) (display #\space port) - (write-uri uri port) + (when (http-proxy-port? port) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (host-port (uri-port uri))) + (when (and scheme host) + (display scheme port) + (display "://" port) + (if (string-index host #\:) + (begin (display #\[ port) + (display host port) + (display #\] port)) + (display host port)) + (unless ((@@ (web uri) default-port?) scheme host-port) + (display #\: port) + (display host-port port))))) + (let ((path (uri-path uri)) + (query (uri-query uri))) + (if (not (string-null? path)) + (display path port)) + (if query + (begin + (display "?" port) + (display query port))) + (if (and (string-null? path) + (not query)) + ;; Make sure we display something. + (display "/" port))) (display #\space port) (write-http-version version port) (display "\r\n" port)) (define (read-response-line port) - "Read the first line of an HTTP response from @var{port}, returning + "Read the first line of an HTTP response from PORT, returning three values: the HTTP version, the response code, and the \"reason phrase\"." (let* ((line (read-line* port)) - (d0 (string-index line char-whitespace?)) ; "delimiter zero" - (d1 (and d0 (string-index line char-whitespace? + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (and d0 (string-index line char-set:whitespace (skip-whitespace line d0))))) (if (and d0 d1) (values (parse-http-version line 0 d0) (parse-non-negative-integer line (skip-whitespace line d0 d1) d1) - (string-trim-both line char-whitespace? d1)) + (string-trim-both line char-set:whitespace d1)) (bad-response "Bad Response-Line: ~s" line)))) (define (write-response-line version code reason-phrase port) - "Write the first line of an HTTP response to @var{port}." + "Write the first line of an HTTP response to PORT." (write-http-version version port) (display #\space port) (display code port) @@ -949,6 +1185,8 @@ phrase\"." ;; emacs: (put 'declare-header! 'scheme-indent-function 1) ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1) (define (declare-opaque-header! name) + "Declares a given header as \"opaque\", meaning that its value is not +treated specially, and is just returned as a plain string." (declare-header! name parse-opaque-string validate-opaque-string write-opaque-string)) @@ -968,7 +1206,7 @@ phrase\"." (lambda (str) (map string->symbol (split-and-trim str))) (lambda (v) - (list-of? symbol? v)) + (list-of? v symbol?)) (lambda (v port) (write-list v port display ", ")))) @@ -986,6 +1224,15 @@ phrase\"." (define (declare-uri-header! name) (declare-header! name (lambda (str) (or (string->uri str) (bad-header-component 'uri str))) + (@@ (web uri) absolute-uri?) + write-uri)) + +;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1) +(define (declare-relative-uri-header! name) + (declare-header! name + (lambda (str) + (or ((@@ (web uri) string->uri*) str) + (bad-header-component 'uri str))) uri? write-uri)) @@ -1068,15 +1315,28 @@ phrase\"." (declare-key-value-list-header! "Cache-Control" (lambda (k v-str) (case k - ((max-age max-stale min-fresh s-maxage) + ((max-age min-fresh s-maxage) (parse-non-negative-integer v-str)) + ((max-stale) + (and v-str (parse-non-negative-integer v-str))) ((private no-cache) (and v-str (split-header-names v-str))) (else v-str))) - default-val-validator + (lambda (k v) + (case k + ((max-age min-fresh s-maxage) + (non-negative-integer? v)) + ((max-stale) + (or (not v) (non-negative-integer? v))) + ((private no-cache) + (or (not v) (list-of-header-names? v))) + ((no-store no-transform only-if-cache must-revalidate proxy-revalidate) + (not v)) + (else + (or (not v) (string? v))))) (lambda (k v port) (cond - ((string? v) (display v port)) + ((string? v) (default-val-writer k v port)) ((pair? v) (display #\" port) (write-header-list v port) @@ -1089,9 +1349,19 @@ phrase\"." ;; Connection = "Connection" ":" 1#(connection-token) ;; connection-token = token ;; e.g. -;; Connection: close, foo-header +;; Connection: close, Foo-Header ;; -(declare-header-list-header! "Connection") +(declare-header! "Connection" + split-header-names + list-of-header-names? + (lambda (val port) + (write-list val port + (lambda (x port) + (display (if (eq? x 'close) + "close" + (header->string x)) + port)) + ", "))) ;; Date = "Date" ":" HTTP-date ;; e.g. @@ -1228,7 +1498,7 @@ phrase\"." ;; Content-Location = ( absoluteURI | relativeURI ) ;; -(declare-uri-header! "Content-Location") +(declare-relative-uri-header! "Content-Location") ;; Content-MD5 = ;; @@ -1295,9 +1565,10 @@ phrase\"." (map (lambda (x) (let ((eq (string-index x #\=))) (if (and eq (= eq (string-rindex x #\=))) - (cons (string->symbol - (string-trim x char-whitespace? 0 eq)) - (string-trim-right x char-whitespace? (1+ eq))) + (cons + (string->symbol + (string-trim x char-set:whitespace 0 eq)) + (string-trim-right x char-set:whitespace (1+ eq))) (bad-header 'content-type str)))) (cdr parts))))) (lambda (val) @@ -1321,7 +1592,15 @@ phrase\"." ;; Expires = HTTP-date ;; -(declare-date-header! "Expires") +(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT")) + +(declare-header! "Expires" + (lambda (str) + (if (member str '("0" "-1")) + *date-in-the-past* + (parse-date str))) + date? + write-date) ;; Last-Modified = HTTP-date ;; @@ -1353,7 +1632,7 @@ phrase\"." (lambda (k v) (if (eq? k 'q) (valid-quality? v) - (string? v))) + (or (not v) (string? v)))) (lambda (k v port) (if (eq? k 'q) (write-quality v port) @@ -1398,18 +1677,32 @@ phrase\"." ;; (declare-header! "Host" (lambda (str) - (let ((colon (string-index str #\:))) - (if colon - (cons (substring str 0 colon) - (parse-non-negative-integer str (1+ colon))) - (cons str #f)))) + (let* ((rbracket (string-index str #\])) + (colon (string-index str #\: (or rbracket 0))) + (host (cond + (rbracket + (unless (eqv? (string-ref str 0) #\[) + (bad-header 'host str)) + (substring str 1 rbracket)) + (colon + (substring str 0 colon)) + (else + str))) + (port (and colon + (parse-non-negative-integer str (1+ colon))))) + (cons host port))) (lambda (val) (and (pair? val) (string? (car val)) (or (not (cdr val)) (non-negative-integer? (cdr val))))) (lambda (val port) - (display (car val) port) + (if (string-index (car val) #\:) + (begin + (display #\[ port) + (display (car val) port) + (display #\] port)) + (display (car val) port)) (if (cdr val) (begin (display #\: port) @@ -1508,7 +1801,7 @@ phrase\"." ;; Referer = ( absoluteURI | relativeURI ) ;; -(declare-uri-header! "Referer") +(declare-relative-uri-header! "Referer") ;; TE = #( t-codings ) ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) @@ -1587,3 +1880,104 @@ phrase\"." ;; WWW-Authenticate = 1#challenge ;; (declare-challenge-list-header! "WWW-Authenticate") + + +;; Chunked Responses +(define (read-chunk-header port) + (let* ((str (read-line port)) + (extension-start (string-index str (lambda (c) (or (char=? c #\;) + (char=? c #\return))))) + (size (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))) + size)) + +(define (read-chunk port) + (let ((size (read-chunk-header port))) + (read-chunk-body port size))) + +(define (read-chunk-body port size) + (let ((bv (get-bytevector-n port size))) + (get-u8 port) ; CR + (get-u8 port) ; LF + bv)) + +(define* (make-chunked-input-port port #:key (keep-alive? #f)) + "Returns a new port which translates HTTP chunked transfer encoded +data from PORT into a non-encoded format. Returns eof when it has +read the final chunk from PORT. This does not necessarily mean +that there is no more data on PORT. When the returned port is +closed it will also close PORT, unless the KEEP-ALIVE? is true." + (define (next-chunk) + (read-chunk port)) + (define finished? #f) + (define (close) + (unless keep-alive? + (close-port port))) + (define buffer #vu8()) + (define buffer-size 0) + (define buffer-pointer 0) + (define (read! bv idx to-read) + (define (loop to-read num-read) + (cond ((or finished? (zero? to-read)) + num-read) + ((<= to-read (- buffer-size buffer-pointer)) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + to-read) + (set! buffer-pointer (+ buffer-pointer to-read)) + (loop 0 (+ num-read to-read))) + (else + (let ((n (- buffer-size buffer-pointer))) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + n) + (set! buffer (next-chunk)) + (set! buffer-pointer 0) + (set! buffer-size (bytevector-length buffer)) + (set! finished? (= buffer-size 0)) + (loop (- to-read n) + (+ num-read n)))))) + (loop to-read 0)) + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + +(define* (make-chunked-output-port port #:key (keep-alive? #f)) + "Returns a new port which translates non-encoded data into a HTTP +chunked transfer encoded data and writes this to PORT. Data +written to this port is buffered until the port is flushed, at which +point it is all sent as one chunk. Take care to close the port when +done, as it will output the remaining data, and encode the final zero +chunk. When the port is closed it will also close PORT, unless +KEEP-ALIVE? is true." + (define (q-for-each f q) + (while (not (q-empty? q)) + (f (deq! q)))) + (define queue (make-q)) + (define (put-char c) + (enq! queue c)) + (define (put-string s) + (string-for-each (lambda (c) (enq! queue c)) + s)) + (define (flush) + ;; It is important that we do _not_ write a chunk if the queue is + ;; empty, since it will be treated as the final chunk. + (unless (q-empty? queue) + (let ((len (q-length queue))) + (display (number->string len 16) port) + (display "\r\n" port) + (q-for-each (lambda (elem) (write-char elem port)) + queue) + (display "\r\n" port)))) + (define (close) + (flush) + (display "0\r\n" port) + (force-output port) + (unless keep-alive? + (close-port port))) + (make-soft-port (vector put-char put-string flush #f close) "w")) + +(define %http-proxy-port? (make-object-property)) +(define (http-proxy-port? port) (%http-proxy-port? port)) +(define (set-http-proxy-port?! port flag) + (set! (%http-proxy-port? port) flag))