3 , MultiParamTypeClasses
9 -- |This module provides functions to parse and format RFC 733 date
10 -- and time strings (<http://tools.ietf.org/html/rfc733#appendix-E>).
12 -- The syntax is as follows:
14 -- > date-time ::= [ day-of-week ", " ] date SP time ("-" | SP) zone
15 -- > day-of-week ::= "Monday" | "Mon" | "Tuesday" | "Tue"
16 -- > | "Wednesday" | "Wed" | "Thursday" | "Thu"
17 -- > | "Friday" | "Fri" | "Saturday" | "Sat"
18 -- > | "Sunday" | "Sun"
19 -- > date ::= day ("-" | SP) month ("-" | SP) year
21 -- > year ::= 2DIGIT | 4DIGIT
22 -- > month ::= "January" | "Jan" | "February" | "Feb"
23 -- > | "March" | "Mar" | "April" | "Apr"
24 -- > | "May" | "June" | "Jun"
25 -- > | "July" | "Jul" | "August" | "Aug"
26 -- > | "September" | "Sep" | "October" | "Oct"
27 -- > | "November" | "Nov" | "December" | "Dec"
28 -- > time ::= hour [ ":" ] minute [ [ ":" ] second ]
30 -- > minute ::= 2DIGIT
31 -- > second ::= 2DIGIT
32 -- > zone ::= "GMT" ; Universal Time
33 -- > | "NST" ; Newfoundland: -3:30
34 -- > | "AST" | "ADT" ; Atlantic : -4 / -3
35 -- > | "EST" | "EDT" ; Eastern : -5 / -4
36 -- > | "CST" | "CDT" ; Central : -6 / -5
37 -- > | "MST" | "MDT" ; Mountain : -7 / -6
38 -- > | "PST" | "PDT" ; Pacific : -8 / -7
39 -- > | "YST" | "YDT" ; Yukon : -9 / -8
40 -- > | "HST" | "HDT" ; Haw/Ala : -10 / -9
41 -- > | "BST" | "BDT" ; Bering : -11 / -10
47 -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM
48 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
58 import Data.Monoid.Unicode
61 import Data.Time.Calendar.WeekDate
62 import Data.Time.Format.HTTP.Common
63 import Data.Time.Format.RFC822
64 import Prelude.Unicode
66 -- |The phantom type for conversions between RFC 733 date and time
67 -- strings and 'ZonedTime'.
69 -- >>> convertSuccess (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC733 ZonedTime)
70 -- "Sunday, 06-Nov-1994 08:49:37 GMT"
73 instance ConvertSuccess (Tagged RFC733 ZonedTime) Ascii where
74 {-# INLINE convertSuccess #-}
75 convertSuccess = A.fromAsciiBuilder ∘ cs
77 instance ConvertSuccess (Tagged RFC733 ZonedTime) AsciiBuilder where
78 {-# INLINE convertSuccess #-}
79 convertSuccess = toAsciiBuilder
81 instance ConvertAttempt Ascii (Tagged RFC733 ZonedTime) where
82 {-# INLINE convertAttempt #-}
83 convertAttempt = parseAttempt' def
85 -- |Parse an RFC 733 date and time string.
86 instance Default (Parser (Tagged RFC733 ZonedTime)) where
87 def = do weekDay ← optionMaybe $
88 do w ← longWeekDayNameP
97 → assertWeekDayIsGood givenWD gregDay
98 (tod, timeZone) ← time
99 let lt = LocalTime gregDay tod
100 zt = ZonedTime lt timeZone
104 date = do day ← read2
105 _ ← char '-' <|> char ' '
106 month ← try longMonthNameP
109 _ ← char '-' <|> char ' '
114 assertGregorianDateIsGood year month day
116 time ∷ Parser (TimeOfDay, TimeZone)
118 _ ← char '-' <|> char ' '
122 hms ∷ Parser TimeOfDay
123 hms = do hour ← read2
124 _ ← optional (char ':')
127 do _ ← optional (char ':')
129 assertTimeOfDayIsGood hour minute second
131 zone ∷ Parser TimeZone
132 zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
134 *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST")
135 , return (TimeZone (1 * 60) False "N")
138 *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST")
139 , string "DT" *> return (TimeZone ((-3) * 60) False "AST")
140 , return (TimeZone ((-1) * 60) False "A")
143 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
144 , string "DT" *> return (TimeZone ((-4) * 60) True "EDT")
147 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
148 , string "DT" *> return (TimeZone ((-5) * 60) True "CDT")
151 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
152 , string "DT" *> return (TimeZone ((-6) * 60) True "MDT")
153 , return (TimeZone ((-12) * 60) False "M")
156 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
157 , string "DT" *> return (TimeZone ((-7) * 60) True "PDT")
160 *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST")
161 , string "DT" *> return (TimeZone ((-8) * 60) True "YDT")
162 , return (TimeZone ( 12 * 60) False "Y")
165 *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST")
166 , string "DT" *> return (TimeZone (( -9) * 60) True "HDT")
169 *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST")
170 , string "DT" *> return (TimeZone ((-10) * 60) True "BDT")
172 , char 'Z' *> return (TimeZone 0 False "Z")
176 toAsciiBuilder ∷ Tagged RFC733 ZonedTime → AsciiBuilder
177 toAsciiBuilder zonedTime
178 = let localTime = zonedTimeToLocalTime $ untag zonedTime
179 timeZone = zonedTimeZone <$> retag' zonedTime
180 (year, month, day) = toGregorian (localDay localTime)
181 (_, _, week) = toWeekDate (localDay localTime)
182 timeOfDay = localTimeOfDay localTime
185 ⊕ A.toAsciiBuilder ", "
187 ⊕ A.toAsciiBuilder "-"
188 ⊕ shortMonthName month
189 ⊕ A.toAsciiBuilder "-"
191 ⊕ A.toAsciiBuilder " "
192 ⊕ show2 (todHour timeOfDay)
193 ⊕ A.toAsciiBuilder ":"
194 ⊕ show2 (todMin timeOfDay)
195 ⊕ A.toAsciiBuilder ":"
196 ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
197 ⊕ A.toAsciiBuilder " "
200 retag' ∷ Tagged τ α → Tagged RFC822 α
203 deriveAttempts [ ([t| Tagged RFC733 ZonedTime |], [t| Ascii |])
204 , ([t| Tagged RFC733 ZonedTime |], [t| AsciiBuilder |])