RFC822
[time-http.git] / Data / Time / RFC822.hs
1 {-# LANGUAGE
2     FlexibleInstances
3   , MultiParamTypeClasses
4   , OverloadedStrings
5   , TemplateHaskell
6   , UnicodeSyntax
7   #-}
8 -- |This module provides functions to parse and format RFC 822 date
9 -- and time formats.
10 --
11 -- The syntax is as follows:
12 --
13 -- > date-time   ::= [ day-of-week ", " ] date SP time SP zone
14 -- > day-of-week ::= "Mon" | "Tue" | "Wed" | "Thu"
15 -- >               | "Fri" | "Sat" | "Sun"
16 -- > date        ::= day SP month SP year
17 -- > day         ::= 2DIGIT
18 -- > year        ::= 2DIGIT             ; Yes, only 2 digits.
19 -- > month       ::= "Jan" | "Feb" | "Mar" | "Apr"
20 -- >               | "May" | "Jun" | "Jul" | "Aug"
21 -- >               | "Sep" | "Oct" | "Nov" | "Dec"
22 -- > time        ::= hour ":" minute [ ":" second ]
23 -- > hour        ::= 2DIGIT
24 -- > minute      ::= 2DIGIT
25 -- > second      ::= 2DIGIT
26 -- > zone        ::= "UT"  | "GMT"      ; Universal Time
27 -- >               | "EST" | "EDT"      ; Eastern : -5 / -4
28 -- >               | "CST" | "CDT"      ; Central : -6 / -5
29 -- >               | "MST" | "MDT"      ; Mountain: -7 / -6
30 -- >               | "PST" | "PDT"      ; Pacific : -8 / -7
31 -- >               | "Z"                ; UT
32 -- >               | "A"                ;  -1
33 -- >               | "M"                ; -12
34 -- >               | "N"                ;  +1
35 -- >               | "Y"                ; +12
36 -- >               | ("+" | "-") 4DIGIT ; Local diff: HHMM
37 module Data.Time.RFC822
38     ( RFC822
39     , rfc822DateAndTime
40     , rfc822Time
41     )
42     where
43 import Control.Applicative
44 import Data.Ascii (Ascii, AsciiBuilder)
45 import qualified Data.Ascii as A
46 import Data.Attoparsec.Char8
47 import Data.Convertible.Base
48 import Data.Monoid.Unicode
49 import Data.Tagged
50 import Data.Time
51 import Data.Time.Calendar.WeekDate
52 import Data.Time.HTTP.Common
53 import Prelude.Unicode
54
55 -- |FIXME: docs
56 data RFC822
57
58 instance ConvertSuccess ZonedTime (Tagged RFC822 Ascii) where
59     {-# INLINE convertSuccess #-}
60     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
61
62 instance ConvertSuccess ZonedTime (Tagged RFC822 AsciiBuilder) where
63     {-# INLINE convertSuccess #-}
64     convertSuccess = Tagged ∘ toAsciiBuilder
65
66 instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where
67     {-# INLINE convertSuccess #-}
68     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
69
70 instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where
71     {-# INLINE convertSuccess #-}
72     convertSuccess tz
73         | timeZoneMinutes tz ≡ 0 = Tagged $ A.toAsciiBuilder "GMT"
74         | otherwise              = Tagged $ show4digitsTZ tz
75
76 instance ConvertAttempt (Tagged RFC822 Ascii) ZonedTime where
77     {-# INLINE convertAttempt #-}
78     convertAttempt = parseAttempt' rfc822DateAndTime ∘ untag
79
80 -- |Parse an RFC 822 date and time string.
81 rfc822DateAndTime ∷ Parser ZonedTime
82 rfc822DateAndTime = dateTime
83
84 dateTime ∷ Parser ZonedTime
85 dateTime = do weekDay ← optionMaybe $
86                         do w ← shortWeekDayNameP
87                            _ ← string ", "
88                            return w
89               gregDay ← date
90               case weekDay of
91                 Nothing
92                     -> return ()
93                 Just givenWD
94                     -> assertWeekDayIsGood givenWD gregDay
95               (tod, timeZone) ← rfc822Time
96               let lt = LocalTime gregDay tod
97                   zt = ZonedTime lt timeZone
98               return zt
99
100 date ∷ Parser Day
101 date = do day   ← read2
102           _     ← char ' '
103           month ← shortMonthNameP
104           _     ← char ' '
105           year  ← (+ 1900) <$> read2
106           _     ← char ' '
107           assertGregorianDateIsGood year month day
108
109 -- |Parse the time and time zone of an RFC 822 date and time string.
110 rfc822Time ∷ Parser (TimeOfDay, TimeZone)
111 rfc822Time = do tod ← hms
112                 _   ← char ' '
113                 tz  ← zone
114                 return (tod, tz)
115
116 hms ∷ Parser TimeOfDay
117 hms = do hour   ← read2
118          minute ← char ':' *> read2
119          second ← option 0 (char ':' *> read2)
120          assertTimeOfDayIsGood hour minute second
121
122 zone ∷ Parser TimeZone
123 zone = choice [ string "UT"  *> return (TimeZone 0 False "UT" )
124               , string "GMT" *> return (TimeZone 0 False "GMT")
125               , char 'E'
126                 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
127                           , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
128                           ]
129               , char 'C'
130                 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
131                           , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
132                           ]
133               , char 'M'
134                 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
135                           , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
136                           , return (TimeZone ((-12) * 60) False "M")
137                           ]
138               , char 'P'
139                 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
140                           , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
141                           ]
142               , char 'Z' *> return (TimeZone 0           False "Z")
143               , char 'A' *> return (TimeZone ((-1) * 60) False "A")
144               , char 'N' *> return (TimeZone (  1  * 60) False "N")
145               , char 'Y' *> return (TimeZone ( 12  * 60) False "Y")
146               , read4digitsTZ
147               ]
148
149 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
150 toAsciiBuilder zonedTime
151     = let localTime          = zonedTimeToLocalTime zonedTime
152           timeZone           = zonedTimeZone zonedTime
153           (year, month, day) = toGregorian (localDay localTime)
154           (_, _, week)       = toWeekDate  (localDay localTime)
155           timeOfDay          = localTimeOfDay localTime
156       in
157         shortWeekDayName week
158         ⊕ A.toAsciiBuilder ", "
159         ⊕ show2 day
160         ⊕ A.toAsciiBuilder " "
161         ⊕ shortMonthName month
162         ⊕ A.toAsciiBuilder " "
163         ⊕ show2 (year `mod` 100)
164         ⊕ A.toAsciiBuilder " "
165         ⊕ show2 (todHour timeOfDay)
166         ⊕ A.toAsciiBuilder ":"
167         ⊕ show2 (todMin timeOfDay)
168         ⊕ A.toAsciiBuilder ":"
169         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
170         ⊕ A.toAsciiBuilder " "
171         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
172
173 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC822 Ascii        |])
174                , ([t| ZonedTime |], [t| Tagged RFC822 AsciiBuilder |])
175                , ([t| TimeZone  |], [t| Tagged RFC822 Ascii        |])
176                , ([t| TimeZone  |], [t| Tagged RFC822 AsciiBuilder |])
177                ]