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>

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)))
+           (make-date 0 second minute hour date month year zone-offset)))
-        ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
+        ((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))))
+  (let ((tail (substring str (1+ comma) space)))
-    (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
+    (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* ((space (string-rindex str #\space))
-      (let ((comma (string-index str #\,)))
+         (zone-offset (and space (false-if-exception
-        (cond ((not comma) (bad-header 'date str))
+                                  (parse-zone-offset str (1+ space))))))
-              ((= comma 3) (parse-rfc-822-date str))
+    (normalize-date
-              (else (parse-rfc-850-date str comma))))
+     (if zone-offset
-      (parse-asctime-date str)))
+         (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)

test-suite/tests/web-http.test

@@ -216,6 +216,9 @@
   (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
                                "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+  (pass-if-parse date "Tue, 15 Nov 1994 16:12:31 +0800"
+                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+                               "~a, ~d ~b ~Y ~H:~M:~S ~z"))
   (pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT"
                  (string->date "Wed, 7 Sep 2011 11:25:00 +0000"
                                "~a,~e ~b ~Y ~H:~M:~S ~z"))