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
44 import Data.Monoid.Unicode
47 import Data.Time.Calendar.WeekDate
48 import Prelude.Unicode
50 shortWeekDayName ∷ Num n ⇒ n → AsciiBuilder
51 {-# INLINE shortWeekDayName #-}
52 shortWeekDayName = A.toAsciiBuilder ∘ go
62 go n = error ("shortWeekDayName: invalid week day: " ⧺ show n)
64 shortWeekDayNameP ∷ Num n ⇒ Parser n
65 {-# INLINEABLE shortWeekDayNameP #-}
67 = choice [ string "Mon" *> return 1
69 *> choice [ string "ue" *> return 2
70 , string "hu" *> return 4
72 , string "Wed" *> return 3
73 , string "Fri" *> return 5
75 *> choice [ string "at" *> return 6
76 , string "un" *> return 7
80 longWeekDayName ∷ Num n ⇒ n → AsciiBuilder
81 {-# INLINE longWeekDayName #-}
82 longWeekDayName = A.toAsciiBuilder ∘ go
92 go n = error ("longWeekDayName: invalid week day: " ⧺ show n)
94 longWeekDayNameP ∷ Num n ⇒ Parser n
95 {-# INLINEABLE longWeekDayNameP #-}
97 = choice [ string "Monday" *> return 1
99 *> choice [ string "uesday" *> return 2
100 , string "hursday" *> return 4
102 , string "Wednesday" *> return 3
103 , string "Friday" *> return 5
105 *> choice [ string "aturday" *> return 6
106 , string "unday" *> return 7
110 shortMonthName ∷ Num n ⇒ n → AsciiBuilder
111 {-# INLINE shortMonthName #-}
112 shortMonthName = A.toAsciiBuilder ∘ go
114 {-# INLINEABLE go #-}
127 go n = error ("shortMonthName: invalid month: " ⧺ show n)
129 shortMonthNameP ∷ Num n ⇒ Parser n
130 {-# INLINEABLE shortMonthNameP #-}
133 *> choice [ string "an" *> return 1
135 *> choice [ char 'n' *> return 6
136 , char 'l' *> return 7
139 , string "Feb" *> return 2
141 *> choice [ char 'r' *> return 3
142 , char 'y' *> return 5
145 *> choice [ string "pr" *> return 4
146 , string "ug" *> return 8
148 , string "Sep" *> return 9
149 , string "Oct" *> return 10
150 , string "Nov" *> return 11
151 , string "Dec" *> return 12
154 longMonthName ∷ Num n ⇒ n → AsciiBuilder
155 {-# INLINE longMonthName #-}
156 longMonthName = A.toAsciiBuilder ∘ go
158 {-# INLINEABLE go #-}
171 go n = error ("longMonthName: invalid month: " ⧺ show n)
173 longMonthNameP ∷ Num n ⇒ Parser n
174 {-# INLINEABLE longMonthNameP #-}
177 *> choice [ string "anuary" *> return 1
179 *> choice [ string "ne" *> return 6
180 , string "ly" *> return 7
183 , string "February" *> return 2
185 *> choice [ string "rch" *> return 3
186 , char 'y' *> return 5
189 *> choice [ string "pril" *> return 4
190 , string "ugust" *> return 8
192 , string "September" *> return 9
193 , string "October" *> return 10
194 , string "November" *> return 11
195 , string "December" *> return 12
198 show4 ∷ Integral i ⇒ i → AsciiBuilder
200 show4 = A.unsafeFromBuilder ∘ go
202 {-# INLINEABLE go #-}
203 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i
204 | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i
205 | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i
206 | i ≥ 0 ∧ i < 10000 = BT.integral i
207 | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)
209 show2 ∷ Integral i ⇒ i → AsciiBuilder
211 show2 = A.unsafeFromBuilder ∘ go
213 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i
214 | i ≥ 0 ∧ i < 100 = BT.integral i
215 | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)
217 show2' ∷ Integral i ⇒ i → AsciiBuilder
218 {-# INLINE show2' #-}
219 show2' = A.unsafeFromBuilder ∘ go
221 go i | i ≥ 0 ∧ i < 10 = B.fromByteString " " ⊕ 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 read4 ∷ Num n ⇒ Parser n
226 {-# INLINEABLE read4 #-}
227 read4 = do n1 ← digit'
231 return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
233 read2 ∷ Num n ⇒ Parser n
234 {-# INLINEABLE read2 #-}
235 read2 = do n1 ← digit'
237 return (n1 * 10 + n2)
239 read2' ∷ Num n ⇒ Parser n
240 {-# INLINEABLE read2' #-}
241 read2' = do n1 ← (char ' ' *> pure 0) <|> digit'
243 return (n1 * 10 + n2)
245 digit' ∷ Num n ⇒ Parser n
246 {-# INLINE digit' #-}
247 digit' = fromIntegral <$> fromC <$> P.digit
250 fromC c = ord c - ord '0'
252 show4digitsTZ ∷ TimeZone → AsciiBuilder
254 = case timeZoneMinutes tz of
255 offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset)
256 | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset
259 = let h = offset `div` 60
264 read4digitsTZ ∷ Parser TimeZone
266 = do sign ← (char '+' *> return 1)
268 (char '-' *> return (-1))
272 timeZoneMinutes = sign * (hour * 60 + minute)
273 , timeZoneSummerOnly = False
274 , timeZoneName = timeZoneOffsetString tz
278 assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m ()
279 {-# INLINEABLE assertWeekDayIsGood #-}
280 assertWeekDayIsGood givenWD gregDay
281 = let (_, _, correctWD ) = toWeekDate gregDay
282 (year, month, day) = toGregorian gregDay
284 unless (givenWD ≡ correctWD)
286 $ concat [ "Gregorian day "
293 , toStr $ longWeekDayName correctWD
295 , toStr $ longWeekDayName givenWD
298 toStr ∷ AsciiBuilder → String
299 toStr = A.toString ∘ A.fromAsciiBuilder
301 assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day
302 {-# INLINEABLE assertGregorianDateIsGood #-}
303 assertGregorianDateIsGood year month day
304 = case fromGregorianValid year month day of
306 → fail $ concat [ "Invalid gregorian day: "
316 assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay
317 {-# INLINEABLE assertTimeOfDayIsGood #-}
318 assertTimeOfDayIsGood hour minute second
319 = case makeTimeOfDayValid hour minute second of
321 → fail $ concat [ "Invalid time of day: "
326 , showFixed True second
331 optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a)
332 {-# INLINE optionMaybe #-}
334 = option Nothing (Just <$> p)