summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArun Isaac2020-12-05 14:16:21 +0530
committerArun Isaac2020-12-05 14:16:21 +0530
commite65b6bacc2adc0c72711ed3b39e533cb6186f3b1 (patch)
tree49050d8b2c7e4f41440b82e96c73b78ec8d8c670
parent37e245539bc9e27db35731e7b517cdde397834e2 (diff)
downloadguile-email-e65b6bacc2adc0c72711ed3b39e533cb6186f3b1.tar.gz
guile-email-e65b6bacc2adc0c72711ed3b39e533cb6186f3b1.tar.lz
guile-email-e65b6bacc2adc0c72711ed3b39e533cb6186f3b1.zip
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.
-rw-r--r--email/email.scm91
-rw-r--r--tests/email.scm28
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