3 , MultiParamTypeClasses
8 -- |This module provides functions to parse and format RFC 733 date
9 -- and time strings (<http://tools.ietf.org/html/rfc733#appendix-E>).
11 -- The syntax is as follows:
13 -- > date-time ::= [ day-of-week ", " ] date SP time ("-" | SP) zone
14 -- > day-of-week ::= "Monday" | "Mon" | "Tuesday" | "Tue"
15 -- > | "Wednesday" | "Wed" | "Thursday" | "Thu"
16 -- > | "Friday" | "Fri" | "Saturday" | "Sat"
17 -- > | "Sunday" | "Sun"
18 -- > date ::= day ("-" | SP) month ("-" | SP) year
20 -- > year ::= 2DIGIT | 4DIGIT
21 -- > month ::= "January" | "Jan" | "February" | "Feb"
22 -- > | "March" | "Mar" | "April" | "Apr"
23 -- > | "May" | "June" | "Jun"
24 -- > | "July" | "Jul" | "August" | "Aug"
25 -- > | "September" | "Sep" | "October" | "Oct"
26 -- > | "November" | "Nov" | "December" | "Dec"
27 -- > time ::= hour [ ":" ] minute [ [ ":" ] second ]
29 -- > minute ::= 2DIGIT
30 -- > second ::= 2DIGIT
31 -- > zone ::= "GMT" ; Universal Time
32 -- > | "NST" ; Newfoundland: -3:30
33 -- > | "AST" | "ADT" ; Atlantic : -4 / -3
34 -- > | "EST" | "EDT" ; Eastern : -5 / -4
35 -- > | "CST" | "CDT" ; Central : -6 / -5
36 -- > | "MST" | "MDT" ; Mountain : -7 / -6
37 -- > | "PST" | "PDT" ; Pacific : -8 / -7
38 -- > | "YST" | "YDT" ; Yukon : -9 / -8
39 -- > | "HST" | "HDT" ; Haw/Ala : -10 / -9
40 -- > | "BST" | "BDT" ; Bering : -11 / -10
46 -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM
47 module Data.Time.Format.RFC733
52 import Control.Applicative
53 import Data.Ascii (Ascii, AsciiBuilder)
54 import qualified Data.Ascii as A
55 import Data.Attoparsec.Char8
56 import Data.Convertible.Base
57 import Data.Monoid.Unicode
60 import Data.Time.Calendar.WeekDate
61 import Data.Time.Format.HTTP.Common
62 import Data.Time.Format.RFC822.Internal
63 import Prelude.Unicode
65 -- |The phantom type for conversions between RFC 733 date and time
66 -- strings and 'ZonedTime'.
68 -- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
69 -- Tagged "Sunday, 06-Nov-1994 08:49:37 GMT"
72 instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where
73 {-# INLINE convertSuccess #-}
74 convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
76 instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where
77 {-# INLINE convertSuccess #-}
78 convertSuccess = Tagged ∘ toAsciiBuilder
80 instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where
81 {-# INLINE convertAttempt #-}
82 convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag
84 -- |Parse an RFC 733 date and time string.
85 rfc733DateAndTime ∷ Parser ZonedTime
86 rfc733DateAndTime = dateTime
88 dateTime ∷ Parser ZonedTime
89 dateTime = do weekDay ← optionMaybe $
90 do w ← longWeekDayNameP
100 → assertWeekDayIsGood givenWD gregDay
101 (tod, timeZone) ← time
102 let lt = LocalTime gregDay tod
103 zt = ZonedTime lt timeZone
107 date = do day ← read2
108 _ ← char '-' <|> char ' '
109 month ← try longMonthNameP
112 _ ← char '-' <|> char ' '
117 assertGregorianDateIsGood year month day
119 time ∷ Parser (TimeOfDay, TimeZone)
121 _ ← char '-' <|> char ' '
125 hms ∷ Parser TimeOfDay
126 hms = do hour ← read2
127 _ ← optional (char ':')
130 do _ ← optional (char ':')
132 assertTimeOfDayIsGood hour minute second
134 zone ∷ Parser TimeZone
135 zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
137 *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST")
138 , return (TimeZone (1 * 60) False "N")
141 *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST")
142 , string "DT" *> return (TimeZone ((-3) * 60) False "AST")
143 , return (TimeZone ((-1) * 60) False "A")
146 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
147 , string "DT" *> return (TimeZone ((-4) * 60) True "EDT")
150 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
151 , string "DT" *> return (TimeZone ((-5) * 60) True "CDT")
154 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
155 , string "DT" *> return (TimeZone ((-6) * 60) True "MDT")
156 , return (TimeZone ((-12) * 60) False "M")
159 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
160 , string "DT" *> return (TimeZone ((-7) * 60) True "PDT")
163 *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST")
164 , string "DT" *> return (TimeZone ((-8) * 60) True "YDT")
165 , return (TimeZone ( 12 * 60) False "Y")
168 *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST")
169 , string "DT" *> return (TimeZone (( -9) * 60) True "HDT")
172 *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST")
173 , string "DT" *> return (TimeZone ((-10) * 60) True "BDT")
175 , char 'Z' *> return (TimeZone 0 False "Z")
179 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
180 toAsciiBuilder zonedTime
181 = let localTime = zonedTimeToLocalTime zonedTime
182 timeZone = zonedTimeZone zonedTime
183 (year, month, day) = toGregorian (localDay localTime)
184 (_, _, week) = toWeekDate (localDay localTime)
185 timeOfDay = localTimeOfDay localTime
188 ⊕ A.toAsciiBuilder ", "
190 ⊕ A.toAsciiBuilder "-"
191 ⊕ shortMonthName month
192 ⊕ A.toAsciiBuilder "-"
194 ⊕ A.toAsciiBuilder " "
195 ⊕ show2 (todHour timeOfDay)
196 ⊕ A.toAsciiBuilder ":"
197 ⊕ show2 (todMin timeOfDay)
198 ⊕ A.toAsciiBuilder ":"
199 ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
200 ⊕ A.toAsciiBuilder " "
201 ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
203 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |])
204 , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |])