diff options
Diffstat (limited to 'module/web/http.scm')
-rw-r--r-- | module/web/http.scm | 93 |
1 files changed, 69 insertions, 24 deletions
diff --git a/module/web/http.scm b/module/web/http.scm index c79d57d78..35169ef5c 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -167,7 +167,7 @@ The default writer is ‘display’." (define *eof* (call-with-input-string "" read)) (define (read-header port) - "Reads one HTTP header from 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. @@ -220,7 +220,7 @@ as an ordered alist." (define (write-headers headers port) "Write the given header alist to PORT. Doesn't write the final -@samp{\\r\\n}, as the user might want to add another header." +‘\\r\\n’, as the user might want to add another header." (let lp ((headers headers)) (if (pair? headers) (begin @@ -702,29 +702,50 @@ as an ordered alist." (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) +(define (parse-rfc-822-date str space zone-offset) ;; We could verify the day of the week but we don't. - (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT") + (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 0))) - ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT") + (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 0))) + (make-date 0 second minute hour date month year zone-offset))) (else (bad-header 'date str) ; prevent tail call #f))) @@ -733,10 +754,10 @@ as an ordered alist." ;; Sunday, 06-Nov-94 08:49:37 GMT ;; 0123456789012345678901 ;; 0 1 2 -(define (parse-rfc-850-date str comma) +(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)))) - (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT")) + (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)) @@ -750,7 +771,7 @@ as an ordered alist." (cond ((< (+ then 50) now) (+ then 100)) ((< (+ now 50) then) (- then 100)) (else then))) - 0)))) + zone-offset)))) ;; ANSI C's asctime() format ;; Sun Nov 6 08:49:37 1994 @@ -770,13 +791,23 @@ as an ordered alist." (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) - (if (string-suffix? " GMT" str) - (let ((comma (string-index str #\,))) - (cond ((not comma) (bad-header 'date str)) - ((= comma 3) (parse-rfc-822-date str)) - (else (parse-rfc-850-date str comma)))) - (parse-asctime-date str))) + (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) (define (display-digits n digits port) @@ -971,7 +1002,7 @@ as an ordered alist." (define *known-versions* '()) (define* (parse-http-version str #:optional (start 0) (end (string-length str))) - "Parse an HTTP version from STR, returning it as a major-minor + "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*)) @@ -1628,18 +1659,32 @@ treated specially, and is just returned as a plain string." ;; (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) |