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.Internal hiding (toAsciiBuilder)
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 ⊕ showRFC822TimeZone timeZone
198 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |])
199 , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |])