3 , MultiParamTypeClasses
8 -- |This module provides functions to parse and format RFC 733 date
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.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.RFC822
62 import Data.Time.HTTP.Common
63 import Prelude.Unicode
68 instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where
69 {-# INLINE convertSuccess #-}
70 convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
72 instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where
73 {-# INLINE convertSuccess #-}
74 convertSuccess = Tagged ∘ toAsciiBuilder
76 instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where
77 {-# INLINE convertAttempt #-}
78 convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag
80 rfc733DateAndTime ∷ Parser ZonedTime
81 rfc733DateAndTime = dateTime
83 dateTime ∷ Parser ZonedTime
84 dateTime = do weekDay ← optionMaybe $
85 do w ← longWeekDayNameP
95 → assertWeekDayIsGood givenWD gregDay
96 (tod, timeZone) ← time
97 let lt = LocalTime gregDay tod
98 zt = ZonedTime lt timeZone
102 date = do day ← read2
103 _ ← char '-' <|> char ' '
104 month ← try longMonthNameP
107 _ ← char '-' <|> char ' '
112 assertGregorianDateIsGood year month day
114 time ∷ Parser (TimeOfDay, TimeZone)
116 _ ← char '-' <|> char ' '
120 hms ∷ Parser TimeOfDay
121 hms = do hour ← read2
122 _ ← optional (char ':')
125 do _ ← optional (char ':')
127 assertTimeOfDayIsGood hour minute second
129 zone ∷ Parser TimeZone
130 zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
132 *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST")
133 , return (TimeZone (1 * 60) False "N")
136 *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST")
137 , string "DT" *> return (TimeZone ((-3) * 60) False "AST")
138 , return (TimeZone ((-1) * 60) False "A")
141 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
142 , string "DT" *> return (TimeZone ((-4) * 60) True "EDT")
145 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
146 , string "DT" *> return (TimeZone ((-5) * 60) True "CDT")
149 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
150 , string "DT" *> return (TimeZone ((-6) * 60) True "MDT")
151 , return (TimeZone ((-12) * 60) False "M")
154 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
155 , string "DT" *> return (TimeZone ((-7) * 60) True "PDT")
158 *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST")
159 , string "DT" *> return (TimeZone ((-8) * 60) True "YDT")
160 , return (TimeZone ( 12 * 60) False "Y")
163 *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST")
164 , string "DT" *> return (TimeZone (( -9) * 60) True "HDT")
167 *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST")
168 , string "DT" *> return (TimeZone ((-10) * 60) True "BDT")
170 , char 'Z' *> return (TimeZone 0 False "Z")
174 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
175 toAsciiBuilder zonedTime
176 = let localTime = zonedTimeToLocalTime zonedTime
177 timeZone = zonedTimeZone zonedTime
178 (year, month, day) = toGregorian (localDay localTime)
179 (_, _, week) = toWeekDate (localDay localTime)
180 timeOfDay = localTimeOfDay localTime
183 ⊕ A.toAsciiBuilder ", "
185 ⊕ A.toAsciiBuilder "-"
186 ⊕ shortMonthName month
187 ⊕ A.toAsciiBuilder "-"
189 ⊕ A.toAsciiBuilder " "
190 ⊕ show2 (todHour timeOfDay)
191 ⊕ A.toAsciiBuilder ":"
192 ⊕ show2 (todMin timeOfDay)
193 ⊕ A.toAsciiBuilder ":"
194 ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
195 ⊕ A.toAsciiBuilder " "
196 ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
198 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |])
199 , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |])