#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parsing and generating rfc2/822 dates.
;; rfc2822 is a more limited version of rfc822.
;; below is the syntax for both rfc822 & rfc2822. from
;; http://tools.ietf.org/html/rfc2822
;; http://tools.ietf.org/html/rfc822
;;
;; NOTE we do not have to worry about CFWS - those would be filtered out by
;; read-network-line module. 
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; yc 10/12/2009 - first version
;; yc 1/18/2010 - convert the module to use bzlib/parseq
;; yc 7/6/2010 - expose make-fixed-digits, digit1-2, digit2, digit4
(require "base.ss" "date.ss" "depend.ss")

#|
RFC822 syntax. we'll allow lower case. 
     date-time   =  [ day "," ] date time        ; dd mm yy
                                                 ;  hh:mm:ss zzz
     
     day         =  "Mon"  / "Tue" /  "Wed"  / "Thu"
                 /  "Fri"  / "Sat" /  "Sun"
     
     date        =  1*2DIGIT month 2DIGIT        ; day month year
                                                 ;  e.g. 20 Jun 82
     
     month       =  "Jan"  /  "Feb" /  "Mar"  /  "Apr"
                 /  "May"  /  "Jun" /  "Jul"  /  "Aug"
                 /  "Sep"  /  "Oct" /  "Nov"  /  "Dec"
     
     time        =  hour zone                    ; ANSI and Military
     
     hour        =  2DIGIT ":" 2DIGIT [":" 2DIGIT]
                                                 ; 00:00:00 - 23:59:59
     
     zone        =  "UT"  / "GMT"                ; Universal Time
                                                 ; North American : UT
                 /  "EST" / "EDT"                ;  Eastern:  - 5/ - 4
                 /  "CST" / "CDT"                ;  Central:  - 6/ - 5
                 /  "MST" / "MDT"                ;  Mountain: - 7/ - 6
                 /  "PST" / "PDT"                ;  Pacific:  - 8/ - 7
                 /  1ALPHA                       ; Military: Z = UT;
                                                 ;  A:-1; (J not used)
                                                 ;  M:-12; N:+1; Y:+12
                 / ( ("+" / "-") 4DIGIT )        ; Local differential
                                                 ;  hours+min. (HHMM)

;;|#
#|

RFC 2822 (allowing lower case).

date-time       =       [ day-of-week "," ] date FWS time [CFWS]

day-of-week     =       ([FWS] day-name) / obs-day-of-week

day-name        =       "Mon" / "Tue" / "Wed" / "Thu" /
                        "Fri" / "Sat" / "Sun"

date            =       day month year

year            =       4*DIGIT / obs-year

month           =       (FWS month-name FWS) / obs-month

month-name      =       "Jan" / "Feb" / "Mar" / "Apr" /
                        "May" / "Jun" / "Jul" / "Aug" /
                        "Sep" / "Oct" / "Nov" / "Dec"

day             =       ([FWS] 1*2DIGIT) / obs-day

time            =       time-of-day FWS zone

time-of-day     =       hour ":" minute [ ":" second ]

hour            =       2DIGIT / obs-hour

minute          =       2DIGIT / obs-minute

second          =       2DIGIT / obs-second

zone            =       (( "+" / "-" ) 4DIGIT) / obs-zone

obs-day-of-week =       [CFWS] day-name [CFWS]

obs-year        =       [CFWS] 2*DIGIT [CFWS]

obs-month       =       CFWS month-name CFWS

obs-day         =       [CFWS] 1*2DIGIT [CFWS]

obs-hour        =       [CFWS] 2DIGIT [CFWS]

obs-minute      =       [CFWS] 2DIGIT [CFWS]

obs-second      =       [CFWS] 2DIGIT [CFWS]

obs-zone        =       "UT" / "GMT" /          ; Universal Time

;;|#
(define month (choice (tokens-ci "Jan" (return 1))
                      (tokens-ci "Feb" (return 2)) 
                      (tokens-ci "Mar" (return 3)) 
                      (tokens-ci "Apr" (return 4)) 
                      (tokens-ci "May" (return 5)) 
                      (tokens-ci "Jun" (return 6)) 
                      (tokens-ci "Jul" (return 7)) 
                      (tokens-ci "Aug" (return 8)) 
                      (tokens-ci "Sep" (return 9)) 
                      (tokens-ci "Oct" (return 10)) 
                      (tokens-ci "Nov" (return 11))
                      (tokens-ci "Dec" (return 12))))

(define (make-fixed-digits min max) 
  (seq digits <- (repeat digit min max) 
       (return (string->number (list->string digits)))))

(define digit1-2 (make-fixed-digits 1 2)) 

(define digit2 (make-fixed-digits 2 2)) 

(define digit4 (make-fixed-digits 4 4)) 

(define time-of-day (tokens hour <- digit1-2 
                            #\: 
                            minute <- digit1-2 
                            second <- 
                            (zero-one (tokens #\:
                                              second <- digit1-2
                                              (return second))
                                      0)
                            (return (list hour minute second)))) 

(define date (tokens day <- digit1-2 
                     m <- month 
                     year <- (choice digit4 digit2)
                     (return (list year m day)))) 

(define (offset hour (minute 0)) 
  (* 60 (+ (* 60 hour) minute)))

(define zone (choice (tokens-ci "UT" (return 0))
                     (tokens-ci "GMT" (return 0)) 
                     (tokens-ci "EST" (return (offset -5)))
                     (tokens-ci "EDT" (return (offset -4))) 
                     (tokens-ci "CST" (return (offset -6))) 
                     (tokens-ci "CDT" (return (offset -5)))
                     (tokens-ci "MST" (return (offset -7))) 
                     (tokens-ci "MDT" (return (offset -6))) 
                     (tokens-ci "PST" (return (offset -8))) 
                     (tokens-ci "PDT" (return (offset -7)))
                     (tokens-ci "A" (return (offset -1)))
                     (tokens-ci "B" (return (offset -2)))
                     (tokens-ci "C" (return (offset -3)))
                     (tokens-ci "D" (return (offset -4)))
                     (tokens-ci "E" (return (offset -5)))
                     (tokens-ci "F" (return (offset -6)))
                     (tokens-ci "G" (return (offset -7)))
                     (tokens-ci "H" (return (offset -8)))
                     (tokens-ci "I" (return (offset -9)))
                     (tokens-ci "K" (return (offset -10)))
                     (tokens-ci "L" (return (offset -11)))
                     (tokens-ci "M" (return (offset -12)))
                     (tokens-ci "N" (return (offset 1)))
                     (tokens-ci "O" (return (offset 2)))
                     (tokens-ci "P" (return (offset 3)))
                     (tokens-ci "Q" (return (offset 4)))
                     (tokens-ci "R" (return (offset 5)))
                     (tokens-ci "S" (return (offset 6)))
                     (tokens-ci "T" (return (offset 7)))
                     (tokens-ci "U" (return (offset 8)))
                     (tokens-ci "V" (return (offset 9)))
                     (tokens-ci "W" (return (offset 10)))
                     (tokens-ci "X" (return (offset 11)))
                     (tokens-ci "Y" (return (offset 12)))
                     (tokens-ci "Z" (return (offset 0)))
                     (tokens sign <- (zero-one (choice (seq #\+ (return +))
                                                       (seq #\- (return -)))
                                               +)
                             offset <- (seq hour <- digit2 
                                            minute <- digit2 
                                            (return (offset hour minute)))
                             (return (sign offset)))
                     ))

(define weekday (choice (tokens-ci "Sun" (return 0))
                        (tokens-ci "Mon" (return 1)) 
                        (tokens-ci "Tue" (return 2)) 
                        (tokens-ci "Wed" (return 3)) 
                        (tokens-ci "Thu" (return 4)) 
                        (tokens-ci "Fri" (return 5)) 
                        (tokens-ci "Sat" (return 6))))

(define (date-helper day time z) 
  (build-date (car day) 
              (cadr day) 
              (caddr day) 
              (car time) 
              (cadr time) 
              (caddr time) 
              #:tz z)) 

(define date-time 
  (tokens (zero-one (tokens w <- weekday #\, (return w)) 0) 
          day <- date 
          time <- time-of-day 
          z <- zone 
          (return (date-helper day time z))))

(define read-rfc822 (make-reader date-time)) 

(define (date->rfc822 d)
  (date->string d "~a, ~d ~b ~Y ~H:~M:~S ~z"))

#|
(define dates
  '("sat, 2 feb 2009 10:10 ut"
    "2 feb 2009 10:10 ut"
    "2 feb 2009 10:10:10 ut"
    "2 feb 2009 10:10:10 +0400"
    "2 feb 2009 10:10:10 0400"
    "2 feb 2009 10:10:10 pdt"
    "2 feb 09 10:10:10 -0400"
    ))

;;(map (lambda (d) (regexp-match re d)) dates)
(map (lambda (d) (rfc822->date d)) dates)
;;|#
;; CONTRACT
(provide/contract
 (read-rfc822 Reader/c)
 (date->rfc822 (-> date? string?))
 (make-fixed-digits (-> exact-nonnegative-integer?
                        exact-nonnegative-integer?
                        Parser/c))
 (digit1-2 Parser/c)
 (digit2 Parser/c)
 (digit4 Parser/c)
 (offset (->* (integer?)
              (integer?) 
              integer?))
 )