summaryrefslogtreecommitdiff
path: root/module/web/http.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/web/http.scm')
-rw-r--r--module/web/http.scm93
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)