From e65b6bacc2adc0c72711ed3b39e533cb6186f3b1 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Sat, 5 Dec 2020 14:16:21 +0530 Subject: 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. --- email/email.scm | 91 ++++++++++++++++++++++++++++++++++++++++++++------------- tests/email.scm | 28 ++++++++++++++++++ 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 +To: Mary Smith +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 -- cgit v1.2.3