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 → AsciiBuilder
48 {-# INLINE shortWeekDayName #-}
49 shortWeekDayName = A.toAsciiBuilder ∘ go
59 go n = error ("shortWeekDayName: invalid week day: " ⧺ show n)
61 shortWeekDayNameP ∷ Num n ⇒ Parser n
62 {-# INLINEABLE shortWeekDayNameP #-}
64 = choice [ string "Mon" *> return 1
66 *> choice [ string "ue" *> return 2
67 , string "hu" *> return 4
69 , string "Wed" *> return 3
70 , string "Fri" *> return 5
72 *> choice [ string "at" *> return 6
73 , string "un" *> return 7
77 longWeekDayName ∷ Num n ⇒ n → AsciiBuilder
78 {-# INLINE longWeekDayName #-}
79 longWeekDayName = A.toAsciiBuilder ∘ go
89 go n = error ("longWeekDayName: invalid week day: " ⧺ show n)
91 longWeekDayNameP ∷ Num n ⇒ Parser n
92 {-# INLINEABLE longWeekDayNameP #-}
94 = choice [ string "Monday" *> return 1
96 *> choice [ string "uesday" *> return 2
97 , string "hursday" *> return 4
99 , string "Wednesday" *> return 3
100 , string "Friday" *> return 5
102 *> choice [ string "aturday" *> return 6
103 , string "unday" *> return 7
107 shortMonthName ∷ Num n ⇒ n → AsciiBuilder
108 {-# INLINE shortMonthName #-}
109 shortMonthName = A.toAsciiBuilder ∘ go
111 {-# INLINEABLE go #-}
124 go n = error ("shortMonthName: invalid month: " ⧺ show n)
126 shortMonthNameP ∷ Num n ⇒ Parser n
127 {-# INLINEABLE shortMonthNameP #-}
130 *> choice [ string "an" *> return 1
132 *> choice [ char 'n' *> return 6
133 , char 'l' *> return 7
136 , string "Feb" *> return 2
138 *> choice [ char 'r' *> return 3
139 , char 'y' *> return 5
142 *> choice [ string "pr" *> return 4
143 , string "ug" *> return 8
145 , string "Sep" *> return 9
146 , string "Oct" *> return 10
147 , string "Nov" *> return 11
148 , string "Dec" *> return 12
151 longMonthName ∷ Num n ⇒ n → AsciiBuilder
152 {-# INLINE longMonthName #-}
153 longMonthName = A.toAsciiBuilder ∘ go
155 {-# INLINEABLE go #-}
168 go n = error ("longMonthName: invalid month: " ⧺ show n)
170 longMonthNameP ∷ Num n ⇒ Parser n
171 {-# INLINEABLE longMonthNameP #-}
174 *> choice [ string "anuary" *> return 1
176 *> choice [ string "ne" *> return 6
177 , string "ly" *> return 7
180 , string "February" *> return 2
182 *> choice [ string "rch" *> return 3
183 , char 'y' *> return 5
186 *> choice [ string "pril" *> return 4
187 , string "ugust" *> return 8
189 , string "September" *> return 9
190 , string "October" *> return 10
191 , string "November" *> return 11
192 , string "December" *> return 12
195 show4 ∷ Integral i ⇒ i → AsciiBuilder
197 show4 = A.unsafeFromBuilder ∘ go
199 {-# INLINEABLE go #-}
200 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i
201 | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i
202 | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i
203 | i ≥ 0 ∧ i < 10000 = BT.integral i
204 | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)
206 show2 ∷ Integral i ⇒ i → AsciiBuilder
208 show2 = A.unsafeFromBuilder ∘ go
210 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i
211 | i ≥ 0 ∧ i < 100 = BT.integral i
212 | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)
214 read4 ∷ Num n ⇒ Parser n
215 {-# INLINEABLE read4 #-}
216 read4 = do n1 ← digit'
220 return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
222 read2 ∷ Num n ⇒ Parser n
223 {-# INLINEABLE read2 #-}
224 read2 = do n1 ← digit'
226 return (n1 * 10 + n2)
228 digit' ∷ Num n ⇒ Parser n
229 digit' = fromC <$> P.digit
231 fromC ∷ Num n ⇒ Char → n
244 show4digitsTZ ∷ TimeZone → AsciiBuilder
246 = case timeZoneMinutes tz of
247 offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset)
248 | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset
251 = let h = offset `div` 60
256 read4digitsTZ ∷ Parser TimeZone
258 = do sign ← (char '+' *> return 1)
260 (char '-' *> return (-1))
264 timeZoneMinutes = sign * (hour * 60 + minute)
265 , timeZoneSummerOnly = False
266 , timeZoneName = timeZoneOffsetString tz
270 assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m ()
271 {-# INLINEABLE assertWeekDayIsGood #-}
272 assertWeekDayIsGood givenWD gregDay
273 = let (_, _, correctWD ) = toWeekDate gregDay
274 (year, month, day) = toGregorian gregDay
276 unless (givenWD ≡ correctWD)
278 $ concat [ "Gregorian day "
285 , toStr $ longWeekDayName correctWD
287 , toStr $ longWeekDayName givenWD
290 toStr ∷ AsciiBuilder → String
291 toStr = A.toString ∘ A.fromAsciiBuilder
293 assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day
294 {-# INLINEABLE assertGregorianDateIsGood #-}
295 assertGregorianDateIsGood year month day
296 = case fromGregorianValid year month day of
298 → fail $ concat [ "Invalid gregorian day: "
308 assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay
309 {-# INLINEABLE assertTimeOfDayIsGood #-}
310 assertTimeOfDayIsGood hour minute second
311 = case makeTimeOfDayValid hour minute second of
313 → fail $ concat [ "Invalid time of day: "
318 , showFixed True second
323 optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a)
324 {-# INLINE optionMaybe #-}
326 = option Nothing (Just <$> p)