summaryrefslogtreecommitdiff
path: root/module/web/http.scm
diff options
context:
space:
mode:
authorDaniel Hartwig <mandyke@gmail.com>2013-03-15 22:25:10 +0800
committerLudovic Courtès <ludo@gnu.org>2013-03-27 18:09:49 +0100
commitffc8eca636a8e9311d35c9adba2fc80476ab11ca (patch)
tree6a5a0c2de4e92e2029ae8ce7fa00f5aa36838098 /module/web/http.scm
parentc548da6949fef565dd1267afa5bbf2c21edda366 (diff)
downloadguile-ffc8eca636a8e9311d35c9adba2fc80476ab11ca.tar.gz
web http: parse numeric time zones in headers
* module/web/http.scm (parse-zone-offset, normalize-date): New procedures. (parse-rfc-822-date, parse-rfc-850-date, parse-date): Update. * test-suite/tests/web-http.test ("general headers"): Add test. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'module/web/http.scm')
-rw-r--r--module/web/http.scm61
1 files changed, 46 insertions, 15 deletions
diff --git a/module/web/http.scm b/module/web/http.scm
index b5202b69c..35169ef5c 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -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)