5 module Data.Time.HTTP.Common
30 , assertGregorianDateIsGood
31 , assertTimeOfDayIsGood
36 import Blaze.ByteString.Builder.ByteString as B
37 import Blaze.Text.Int as BT
38 import Control.Applicative
40 import Data.Ascii (AsciiBuilder)
41 import qualified Data.Ascii as A
42 import Data.Attoparsec.Char8 as P
43 import Data.Monoid.Unicode
46 import Data.Time.Calendar.WeekDate
47 import Prelude.Unicode
49 shortWeekDayName ∷ Num n ⇒ n → AsciiBuilder
50 {-# INLINE shortWeekDayName #-}
51 shortWeekDayName = A.toAsciiBuilder ∘ go
61 go n = error ("shortWeekDayName: invalid week day: " ⧺ show n)
63 shortWeekDayNameP ∷ Num n ⇒ Parser n
64 {-# INLINEABLE shortWeekDayNameP #-}
66 = choice [ string "Mon" *> return 1
68 *> choice [ string "ue" *> return 2
69 , string "hu" *> return 4
71 , string "Wed" *> return 3
72 , string "Fri" *> return 5
74 *> choice [ string "at" *> return 6
75 , string "un" *> return 7
79 longWeekDayName ∷ Num n ⇒ n → AsciiBuilder
80 {-# INLINE longWeekDayName #-}
81 longWeekDayName = A.toAsciiBuilder ∘ go
91 go n = error ("longWeekDayName: invalid week day: " ⧺ show n)
93 longWeekDayNameP ∷ Num n ⇒ Parser n
94 {-# INLINEABLE longWeekDayNameP #-}
96 = choice [ string "Monday" *> return 1
98 *> choice [ string "uesday" *> return 2
99 , string "hursday" *> return 4
101 , string "Wednesday" *> return 3
102 , string "Friday" *> return 5
104 *> choice [ string "aturday" *> return 6
105 , string "unday" *> return 7
109 shortMonthName ∷ Num n ⇒ n → AsciiBuilder
110 {-# INLINE shortMonthName #-}
111 shortMonthName = A.toAsciiBuilder ∘ go
113 {-# INLINEABLE go #-}
126 go n = error ("shortMonthName: invalid month: " ⧺ show n)
128 shortMonthNameP ∷ Num n ⇒ Parser n
129 {-# INLINEABLE shortMonthNameP #-}
132 *> choice [ string "an" *> return 1
134 *> choice [ char 'n' *> return 6
135 , char 'l' *> return 7
138 , string "Feb" *> return 2
140 *> choice [ char 'r' *> return 3
141 , char 'y' *> return 5
144 *> choice [ string "pr" *> return 4
145 , string "ug" *> return 8
147 , string "Sep" *> return 9
148 , string "Oct" *> return 10
149 , string "Nov" *> return 11
150 , string "Dec" *> return 12
153 longMonthName ∷ Num n ⇒ n → AsciiBuilder
154 {-# INLINE longMonthName #-}
155 longMonthName = A.toAsciiBuilder ∘ go
157 {-# INLINEABLE go #-}
170 go n = error ("longMonthName: invalid month: " ⧺ show n)
172 longMonthNameP ∷ Num n ⇒ Parser n
173 {-# INLINEABLE longMonthNameP #-}
176 *> choice [ string "anuary" *> return 1
178 *> choice [ string "ne" *> return 6
179 , string "ly" *> return 7
182 , string "February" *> return 2
184 *> choice [ string "rch" *> return 3
185 , char 'y' *> return 5
188 *> choice [ string "pril" *> return 4
189 , string "ugust" *> return 8
191 , string "September" *> return 9
192 , string "October" *> return 10
193 , string "November" *> return 11
194 , string "December" *> return 12
197 show4 ∷ Integral i ⇒ i → AsciiBuilder
199 show4 = A.unsafeFromBuilder ∘ go
201 {-# INLINEABLE go #-}
202 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i
203 | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i
204 | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i
205 | i ≥ 0 ∧ i < 10000 = BT.integral i
206 | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)
208 show2 ∷ Integral i ⇒ i → AsciiBuilder
210 show2 = A.unsafeFromBuilder ∘ go
212 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i
213 | i ≥ 0 ∧ i < 100 = BT.integral i
214 | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)
216 show2' ∷ Integral i ⇒ i → AsciiBuilder
217 {-# INLINE show2' #-}
218 show2' = A.unsafeFromBuilder ∘ go
220 go i | i ≥ 0 ∧ i < 10 = B.fromByteString " " ⊕ BT.digit i
221 | i ≥ 0 ∧ i < 100 = BT.integral i
222 | otherwise = error ("show2': the integer i must satisfy 0 <= i < 100: " ⧺ show i)
224 read4 ∷ Num n ⇒ Parser n
225 {-# INLINEABLE read4 #-}
226 read4 = do n1 ← digit'
230 return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
232 read2 ∷ Num n ⇒ Parser n
233 {-# INLINEABLE read2 #-}
234 read2 = do n1 ← digit'
236 return (n1 * 10 + n2)
238 read2' ∷ Num n ⇒ Parser n
239 {-# INLINEABLE read2' #-}
240 read2' = do n1 ← (char ' ' *> pure 0) <|> digit'
242 return (n1 * 10 + n2)
244 digit' ∷ Num n ⇒ Parser n
245 digit' = fromC <$> P.digit
247 fromC ∷ Num n ⇒ Char → n
260 show4digitsTZ ∷ TimeZone → AsciiBuilder
262 = case timeZoneMinutes tz of
263 offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset)
264 | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset
267 = let h = offset `div` 60
272 read4digitsTZ ∷ Parser TimeZone
274 = do sign ← (char '+' *> return 1)
276 (char '-' *> return (-1))
280 timeZoneMinutes = sign * (hour * 60 + minute)
281 , timeZoneSummerOnly = False
282 , timeZoneName = timeZoneOffsetString tz
286 assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m ()
287 {-# INLINEABLE assertWeekDayIsGood #-}
288 assertWeekDayIsGood givenWD gregDay
289 = let (_, _, correctWD ) = toWeekDate gregDay
290 (year, month, day) = toGregorian gregDay
292 unless (givenWD ≡ correctWD)
294 $ concat [ "Gregorian day "
301 , toStr $ longWeekDayName correctWD
303 , toStr $ longWeekDayName givenWD
306 toStr ∷ AsciiBuilder → String
307 toStr = A.toString ∘ A.fromAsciiBuilder
309 assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day
310 {-# INLINEABLE assertGregorianDateIsGood #-}
311 assertGregorianDateIsGood year month day
312 = case fromGregorianValid year month day of
314 → fail $ concat [ "Invalid gregorian day: "
324 assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay
325 {-# INLINEABLE assertTimeOfDayIsGood #-}
326 assertTimeOfDayIsGood hour minute second
327 = case makeTimeOfDayValid hour minute second of
329 → fail $ concat [ "Invalid time of day: "
334 , showFixed True second
339 optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a)
340 {-# INLINE optionMaybe #-}
342 = option Nothing (Just <$> p)