5 module Data.Time.HTTP.Common
28 , assertGregorianDateIsGood
29 , assertTimeOfDayIsGood
34 import Blaze.ByteString.Builder.ByteString as B
35 import Blaze.Text.Int as BT
36 import Control.Applicative
38 import Data.Ascii (AsciiBuilder)
39 import qualified Data.Ascii as A
40 import Data.Attoparsec.Char8 as P
41 import Data.Monoid.Unicode
44 import Data.Time.Calendar.WeekDate
45 import Prelude.Unicode
47 shortWeekDayName ∷ Num n ⇒ n → String
48 {-# INLINEABLE shortWeekDayName #-}
49 shortWeekDayName 1 = "Mon"
50 shortWeekDayName 2 = "Tue"
51 shortWeekDayName 3 = "Wed"
52 shortWeekDayName 4 = "Thu"
53 shortWeekDayName 5 = "Fri"
54 shortWeekDayName 6 = "Sat"
55 shortWeekDayName 7 = "Sun"
56 shortWeekDayName n = error ("shortWeekDayName: invalid week day: " ⧺ show n)
58 shortWeekDayNameP ∷ Num n ⇒ Parser n
59 {-# INLINEABLE shortWeekDayNameP #-}
61 = choice [ string "Mon" *> return 1
63 *> choice [ string "ue" *> return 2
64 , string "hu" *> return 4
66 , string "Wed" *> return 3
67 , string "Fri" *> return 5
69 *> choice [ string "at" *> return 6
70 , string "un" *> return 7
74 longWeekDayName ∷ Num n ⇒ n → String
75 {-# INLINEABLE longWeekDayName #-}
76 longWeekDayName 1 = "Monday"
77 longWeekDayName 2 = "Tuesday"
78 longWeekDayName 3 = "Wednesday"
79 longWeekDayName 4 = "Thursday"
80 longWeekDayName 5 = "Friday"
81 longWeekDayName 6 = "Saturday"
82 longWeekDayName 7 = "Sunday"
83 longWeekDayName n = error ("longWeekDayName: invalid week day: " ⧺ show n)
85 longWeekDayNameP ∷ Num n ⇒ Parser n
86 {-# INLINEABLE longWeekDayNameP #-}
88 = choice [ string "Monday" *> return 1
90 *> choice [ string "uesday" *> return 2
91 , string "hursday" *> return 4
93 , string "Wednesday" *> return 3
94 , string "Friday" *> return 5
96 *> choice [ string "aturday" *> return 6
97 , string "unday" *> return 7
101 shortMonthName ∷ Num n ⇒ n → String
102 {-# INLINEABLE shortMonthName #-}
103 shortMonthName 1 = "Jan"
104 shortMonthName 2 = "Feb"
105 shortMonthName 3 = "Mar"
106 shortMonthName 4 = "Apr"
107 shortMonthName 5 = "May"
108 shortMonthName 6 = "Jun"
109 shortMonthName 7 = "Jul"
110 shortMonthName 8 = "Aug"
111 shortMonthName 9 = "Sep"
112 shortMonthName 10 = "Oct"
113 shortMonthName 11 = "Nov"
114 shortMonthName 12 = "Dec"
115 shortMonthName n = error ("shortMonthName: invalid month: " ⧺ show n)
117 shortMonthNameP ∷ Num n ⇒ Parser n
118 {-# INLINEABLE shortMonthNameP #-}
121 *> choice [ string "an" *> return 1
123 *> choice [ char 'n' *> return 6
124 , char 'l' *> return 7
127 , string "Feb" *> return 2
129 *> choice [ char 'r' *> return 3
130 , char 'y' *> return 5
133 *> choice [ string "pr" *> return 4
134 , string "ug" *> return 8
136 , string "Sep" *> return 9
137 , string "Oct" *> return 10
138 , string "Nov" *> return 11
139 , string "Dec" *> return 12
142 longMonthName ∷ Num n ⇒ n → String
143 {-# INLINEABLE longMonthName #-}
144 longMonthName 1 = "January"
145 longMonthName 2 = "February"
146 longMonthName 3 = "March"
147 longMonthName 4 = "April"
148 longMonthName 5 = "May"
149 longMonthName 6 = "June"
150 longMonthName 7 = "July"
151 longMonthName 8 = "August"
152 longMonthName 9 = "September"
153 longMonthName 10 = "October"
154 longMonthName 11 = "November"
155 longMonthName 12 = "December"
156 longMonthName n = error ("longMonthName: invalid month: " ⧺ show n)
158 longMonthNameP ∷ Num n ⇒ Parser n
159 {-# INLINEABLE longMonthNameP #-}
162 *> choice [ string "anuary" *> return 1
164 *> choice [ string "ne" *> return 6
165 , string "ly" *> return 7
168 , string "February" *> return 2
170 *> choice [ string "rch" *> return 3
171 , char 'y' *> return 5
174 *> choice [ string "pril" *> return 4
175 , string "ugust" *> return 8
177 , string "September" *> return 9
178 , string "October" *> return 10
179 , string "November" *> return 11
180 , string "December" *> return 12
183 show4 ∷ Integral i ⇒ i → AsciiBuilder
185 show4 = A.unsafeFromBuilder ∘ go
187 {-# INLINEABLE go #-}
188 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i
189 | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i
190 | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i
191 | i ≥ 0 ∧ i < 10000 = BT.integral i
192 | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)
194 show2 ∷ Integral i ⇒ i → AsciiBuilder
196 show2 = A.unsafeFromBuilder ∘ go
198 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i
199 | i ≥ 0 ∧ i < 100 = BT.integral i
200 | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)
202 read4 ∷ Num n ⇒ Parser n
203 {-# INLINEABLE read4 #-}
204 read4 = do n1 ← digit'
208 return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
210 read2 ∷ Num n ⇒ Parser n
211 {-# INLINEABLE read2 #-}
212 read2 = do n1 ← digit'
214 return (n1 * 10 + n2)
216 digit' ∷ Num n ⇒ Parser n
217 digit' = fromC <$> P.digit
219 fromC ∷ Num n ⇒ Char → n
232 show4digitsTZ ∷ TimeZone → AsciiBuilder
234 = case timeZoneMinutes tz of
235 offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset)
236 | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset
239 = let h = offset `div` 60
244 read4digitsTZ ∷ Parser TimeZone
246 = do sign ← (char '+' *> return 1)
248 (char '-' *> return (-1))
252 timeZoneMinutes = sign * (hour * 60 + minute)
253 , timeZoneSummerOnly = False
254 , timeZoneName = timeZoneOffsetString tz
258 assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m ()
259 {-# INLINEABLE assertWeekDayIsGood #-}
260 assertWeekDayIsGood givenWD gregDay
261 = let (_, _, correctWD ) = toWeekDate gregDay
262 (year, month, day) = toGregorian gregDay
264 unless (givenWD ≡ correctWD)
266 $ concat [ "Gregorian day "
273 , longWeekDayName correctWD
275 , longWeekDayName givenWD
278 assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day
279 {-# INLINEABLE assertGregorianDateIsGood #-}
280 assertGregorianDateIsGood year month day
281 = case fromGregorianValid year month day of
283 → fail $ concat [ "Invalid gregorian day: "
293 assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay
294 {-# INLINEABLE assertTimeOfDayIsGood #-}
295 assertTimeOfDayIsGood hour minute second
296 = case makeTimeOfDayValid hour minute second of
298 → fail $ concat [ "Invalid time of day: "
303 , showFixed True second
308 optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a)
309 {-# INLINE optionMaybe #-}
311 = option Nothing (Just <$> p)