email: Support obsolete date and time.

* email/email.scm (obs-day-of-week, obs-day, obs-year, obs-hour,
obs-minute, obs-second, obs-zone): New macros.
(day-of-week, day, year, hours, minutes, seconds, zone): Include
obsolete pattern.
(parse-email-headers): Handle obsolete two and three digit years, and
alphabetic time zone specifiers.
* tests/email.scm ("RFC5322 A.6.2. Obsolete dates"): New test.

2 files changed, 99 insertions, 20 deletions

diff --git a/email/email.scm b/email/email.scm
index 52f7f58..56c1b57 100644
--- a/email/email.scm
+++ b/email/email.scm
@@ -227,32 +227,61 @@
 (define-peg-pattern day-name body
   (or "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
 
+(define-peg-pattern obs-day-of-week body
+  (and (ignore (? cfws)) day-name (ignore (? cfws))))
+
+;; We set day-of-week to be the same as obs-day-of-week since,
+;; according to their definitions in RFC5322, all days-of-week are
+;; obs-days-of-week.
 (define-peg-pattern day-of-week all
-  (and (ignore (? fws)) day-name))
+  obs-day-of-week)
 
-;; TODO: Remove workaround guile peg bug for ignore
+(define-peg-pattern obs-day body
+  (and (ignore (? cfws)) digit (? digit) (ignore (? cfws))))
+
+;; We set day to be the same as obs-day since, according to their
+;; definitions in RFC5322, all days are obs-days.
 (define-peg-pattern day all
-  (and (ignore (? fws)) digit (? digit) (ignore (and fws))))
+  obs-day)
 
 (define-peg-pattern month all
   (or "Jan" "Feb" "Mar" "Apr" "May" "Jun"
       "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 
-;; TODO: Remove workaround guile peg bug for ignore
+(define-peg-pattern obs-year body
+  (and (ignore (? cfws)) (and digit digit) (* digit) (ignore (? cfws))))
+
+;; We set year to be the same as obs-year since, according to their
+;; definitions in RFC5322, all years are obs-years.
 (define-peg-pattern year all
-  (and (ignore (and fws)) digit digit digit digit (ignore (and fws))))
+  obs-year)
 
 (define-peg-pattern date all
   (and day month year))
 
+(define-peg-pattern obs-hour body
+  (and (ignore (? cfws)) digit digit (ignore (? cfws))))
+
+;; We set hours to be the same as obs-hour since, according to their
+;; definitions in RFC5322, all hours are obs-hours.
 (define-peg-pattern hours all
-  (and digit digit))
+  obs-hour)
 
+(define-peg-pattern obs-minute body
+  (and (ignore (? cfws)) digit digit (ignore (? cfws))))
+
+;; We set minutes to be the same as obs-minute since, according to
+;; their definitions in RFC5322, all minutes are obs-minutes.
 (define-peg-pattern minutes all
-  (and digit digit))
+  obs-minute)
+
+(define-peg-pattern obs-second body
+  (and (ignore (? cfws)) digit digit (ignore (? cfws))))
 
+;; We set seconds to be the same as obs-second since, according to
+;; their definitions in RFC5322, all seconds are obs-seconds.
 (define-peg-pattern seconds all
-  (and digit digit))
+  obs-second)
 
 (define-peg-pattern time-of-day all
   (and hours (ignore ":") minutes (? (and (ignore ":") seconds))))
@@ -270,9 +299,17 @@
 (define-peg-pattern zone-minutes all
   (and digit digit))
 
-;; TODO: Remove workaround guile peg bug for ignore
+(define-peg-pattern obs-zone body
+  (or "UT" "GMT"
+      "EST" "EDT" "CST" "CDT"
+      "MST" "MDT" "PST" "PDT"
+      (and (not-followed-by (or "j" "J"))
+           (or (range #\a #\z)
+               (range #\A #\Z)))))
+
 (define-peg-pattern zone all
-  (and (ignore (and fws)) zone-sign zone-hours zone-minutes))
+  (or (and zone-sign zone-hours zone-minutes)
+      obs-zone))
 
 (define-peg-pattern time all
   (and time-of-day zone))
@@ -954,11 +991,9 @@ list of header keys and values."
    `((date-time . ,(lambda node
                      (match-let
                          ((`((day ,day) (month ,month) (year ,year)
-                             (hours ,hours) (minutes ,minutes) (seconds ,seconds)
-                             (zone-sign ,zone-sign) (zone-hours ,zone-hours) (zone-minutes ,zone-minutes))
+                             (hours ,hours) (minutes ,minutes) (seconds ,seconds) (zone . ,zone))
                            (flatten-and-filter
-                            '(day month year hours minutes seconds
-                                  zone-sign zone-hours zone-minutes)
+                            '(day month year hours minutes seconds zone)
                             node)))
                        (make-date 0
                                   (string->number seconds)
@@ -969,12 +1004,28 @@ list of header keys and values."
                                        (cut equal? <> month)
                                        (list "Jan" "Feb" "Mar" "Apr" "May" "Jun"
                                              "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
-                                  (string->number year)
-                                  (* (case (string->symbol zone-sign)
-                                       ((+) 1)
-                                       ((-) -1))
-                                     (+ (* 60 60 (string->number zone-hours))
-                                        (* 60 (string->number zone-minutes))))))))
+                                  (let ((year (string->number year)))
+                                    (cond
+                                     ((and (>= year 0) (<= year 49))
+                                      (+ year 2000))
+                                     ((and (>= year 50) (<= year 999))
+                                      (+ year 1900))
+                                     (else year)))
+                                  (match zone
+                                    (((or "UT" "GMT")) 0)
+                                    (("EDT") (* -4 3600))
+                                    (((or "EST" "CDT")) (* -5 3600))
+                                    (((or "CST" "MDT")) (* -6 3600))
+                                    (((or "MST" "PDT")) (* -7 3600))
+                                    (("PST") (* -8 3600))
+                                    (`((zone-sign ,zone-sign)
+                                       (zone-hours ,zone-hours)
+                                       (zone-minutes ,zone-minutes))
+                                     (* (case (string->symbol zone-sign)
+                                          ((+) 1)
+                                          ((-) -1))
+                                        (+ (* 60 60 (string->number zone-hours))
+                                           (* 60 (string->number zone-minutes))))))))))
      (orig-date . ,(lambda (_ date) (list 'date date)))
      (mailbox . ,post-process-mailbox)
      (address-list *macro* . ,macro-process-address-list)
diff --git a/tests/email.scm b/tests/email.scm
index 8a7be9b..d3801a9 100644
--- a/tests/email.scm
+++ b/tests/email.scm
@@ -215,6 +215,34 @@ Hi everyone.
      (content-transfer-encoding . 7bit))
    "Hi everyone."))
 
+(test-email= "RFC5322 A.6.2. Obsolete dates"
+  (parse-email
+   (string->bytevector
+    "From: John Doe <jdoe@machine.example>
+To: Mary Smith <mary@example.net>
+Subject: Saying Hello
+Date: 21 Nov 97 09:55:06 GMT
+Message-ID: <1234@local.machine.example>
+
+This is a message just to say hello.
+So, \"Hello\".
+"
+    "utf-8"))
+  (make-email
+   `((from ((name . "John Doe")
+            (address . "jdoe@machine.example")))
+     (to ((name . "Mary Smith")
+          (address . "mary@example.net")))
+     (subject . "Saying Hello")
+     (date . ,(make-date 0 6 55 9 21 11 1997 0))
+     (message-id . "1234@local.machine.example")
+     (content-type (type . text)
+                   (subtype . plain)
+                   (charset . "utf-8"))
+     (content-transfer-encoding . 7bit))
+   "This is a message just to say hello.
+So, \"Hello\"."))
+
 (test-email= "RFC2046 5.1.1. Common syntax"
   (parse-email
    (string->bytevector