5 module Data.Time.HTTP.Common
30 , assertGregorianDateIsGood
31 , assertTimeOfDayIsGood
40 import Blaze.ByteString.Builder.ByteString as B
41 import Blaze.Text.Int as BT
42 import Control.Applicative
43 import Control.Exception.Base
45 import Control.Monad.Unicode
46 import Data.Ascii (Ascii, AsciiBuilder)
47 import qualified Data.Ascii as A
49 import Data.Attoparsec.Char8 as P
50 import Data.ByteString (ByteString)
52 import Data.Monoid.Unicode
55 import Data.Time.Calendar.WeekDate
56 import Prelude.Unicode
58 shortWeekDayName ∷ Num n ⇒ n → AsciiBuilder
59 {-# INLINE shortWeekDayName #-}
60 shortWeekDayName = A.toAsciiBuilder ∘ go
70 go n = error ("shortWeekDayName: invalid week day: " ⧺ show n)
72 shortWeekDayNameP ∷ Num n ⇒ Parser n
73 {-# INLINEABLE shortWeekDayNameP #-}
75 = choice [ string "Mon" *> return 1
77 *> choice [ string "ue" *> return 2
78 , string "hu" *> return 4
80 , string "Wed" *> return 3
81 , string "Fri" *> return 5
83 *> choice [ string "at" *> return 6
84 , string "un" *> return 7
88 longWeekDayName ∷ Num n ⇒ n → AsciiBuilder
89 {-# INLINE longWeekDayName #-}
90 longWeekDayName = A.toAsciiBuilder ∘ go
100 go n = error ("longWeekDayName: invalid week day: " ⧺ show n)
102 longWeekDayNameP ∷ Num n ⇒ Parser n
103 {-# INLINEABLE longWeekDayNameP #-}
105 = choice [ string "Monday" *> return 1
107 *> choice [ string "uesday" *> return 2
108 , string "hursday" *> return 4
110 , string "Wednesday" *> return 3
111 , string "Friday" *> return 5
113 *> choice [ string "aturday" *> return 6
114 , string "unday" *> return 7
118 shortMonthName ∷ Num n ⇒ n → AsciiBuilder
119 {-# INLINE shortMonthName #-}
120 shortMonthName = A.toAsciiBuilder ∘ go
122 {-# INLINEABLE go #-}
135 go n = error ("shortMonthName: invalid month: " ⧺ show n)
137 shortMonthNameP ∷ Num n ⇒ Parser n
138 {-# INLINEABLE shortMonthNameP #-}
141 *> choice [ string "an" *> return 1
143 *> choice [ char 'n' *> return 6
144 , char 'l' *> return 7
147 , string "Feb" *> return 2
149 *> choice [ char 'r' *> return 3
150 , char 'y' *> return 5
153 *> choice [ string "pr" *> return 4
154 , string "ug" *> return 8
156 , string "Sep" *> return 9
157 , string "Oct" *> return 10
158 , string "Nov" *> return 11
159 , string "Dec" *> return 12
162 longMonthName ∷ Num n ⇒ n → AsciiBuilder
163 {-# INLINE longMonthName #-}
164 longMonthName = A.toAsciiBuilder ∘ go
166 {-# INLINEABLE go #-}
179 go n = error ("longMonthName: invalid month: " ⧺ show n)
181 longMonthNameP ∷ Num n ⇒ Parser n
182 {-# INLINEABLE longMonthNameP #-}
185 *> choice [ string "anuary" *> return 1
187 *> choice [ string "ne" *> return 6
188 , string "ly" *> return 7
191 , string "February" *> return 2
193 *> choice [ string "rch" *> return 3
194 , char 'y' *> return 5
197 *> choice [ string "pril" *> return 4
198 , string "ugust" *> return 8
200 , string "September" *> return 9
201 , string "October" *> return 10
202 , string "November" *> return 11
203 , string "December" *> return 12
206 show4 ∷ Integral i ⇒ i → AsciiBuilder
208 show4 = A.unsafeFromBuilder ∘ go
210 {-# INLINEABLE go #-}
211 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i
212 | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i
213 | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i
214 | i ≥ 0 ∧ i < 10000 = BT.integral i
215 | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)
217 show2 ∷ Integral i ⇒ i → AsciiBuilder
219 show2 = A.unsafeFromBuilder ∘ go
221 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i
222 | i ≥ 0 ∧ i < 100 = BT.integral i
223 | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)
225 show2' ∷ Integral i ⇒ i → AsciiBuilder
226 {-# INLINE show2' #-}
227 show2' = A.unsafeFromBuilder ∘ go
229 go i | i ≥ 0 ∧ i < 10 = B.fromByteString " " ⊕ BT.digit i
230 | i ≥ 0 ∧ i < 100 = BT.integral i
231 | otherwise = error ("show2': the integer i must satisfy 0 <= i < 100: " ⧺ show i)
233 read4 ∷ Num n ⇒ Parser n
234 {-# INLINEABLE read4 #-}
235 read4 = do n1 ← digit'
239 return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
241 read2 ∷ Num n ⇒ Parser n
242 {-# INLINEABLE read2 #-}
243 read2 = do n1 ← digit'
245 return (n1 * 10 + n2)
247 read2' ∷ Num n ⇒ Parser n
248 {-# INLINEABLE read2' #-}
249 read2' = do n1 ← (char ' ' *> pure 0) <|> digit'
251 return (n1 * 10 + n2)
253 digit' ∷ Num n ⇒ Parser n
254 {-# INLINE digit' #-}
255 digit' = fromIntegral <$> fromC <$> P.digit
258 fromC c = ord c - ord '0'
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)
344 finishOff ∷ Parser α → Parser α
345 {-# INLINE finishOff #-}
346 finishOff = ((endOfInput *>) ∘ return =≪)
348 parseAttempt ∷ Exception e
353 {-# INLINEABLE parseAttempt #-}
355 = case parseOnly (finishOff p) bs of
357 Left e → Failure $ f e
359 parseAttempt' ∷ Parser α → Ascii → Attempt α
360 {-# INLINE parseAttempt' #-}
361 parseAttempt' = (∘ A.toByteString) ∘ parseAttempt StringException