5 module Data.Time.HTTP.Common
28 , assertGregorianDateIsGood
29 , assertTimeOfDayIsGood
32 import Blaze.ByteString.Builder.ByteString as B
33 import Blaze.Text.Int as BT
34 import Control.Applicative
36 import Control.Monad.Unicode
37 import Data.Ascii (AsciiBuilder)
38 import qualified Data.Ascii as A
39 import Data.Attoparsec.Char8 as P
40 import Data.Monoid.Unicode
43 import Data.Time.Calendar.WeekDate
44 import Prelude.Unicode
46 shortWeekDayName ∷ Num n ⇒ n → String
47 {-# INLINEABLE shortWeekDayName #-}
48 shortWeekDayName 1 = "Mon"
49 shortWeekDayName 2 = "Tue"
50 shortWeekDayName 3 = "Wed"
51 shortWeekDayName 4 = "Thu"
52 shortWeekDayName 5 = "Fri"
53 shortWeekDayName 6 = "Sat"
54 shortWeekDayName 7 = "Sun"
55 shortWeekDayName n = error ("shortWeekDayName: invalid week day: " ⧺ show n)
57 shortWeekDayNameP ∷ Num n ⇒ Parser n
58 {-# INLINEABLE shortWeekDayNameP #-}
60 = choice [ string "Mon" ≫ return 1
62 ≫ choice [ string "ue" ≫ return 2
63 , string "hu" ≫ return 4
65 , string "Wed" ≫ return 3
66 , string "Fri" ≫ return 5
68 ≫ choice [ string "at" ≫ return 6
69 , string "un" ≫ return 7
73 longWeekDayName ∷ Num n ⇒ n → String
74 {-# INLINEABLE longWeekDayName #-}
75 longWeekDayName 1 = "Monday"
76 longWeekDayName 2 = "Tuesday"
77 longWeekDayName 3 = "Wednesday"
78 longWeekDayName 4 = "Thursday"
79 longWeekDayName 5 = "Friday"
80 longWeekDayName 6 = "Saturday"
81 longWeekDayName 7 = "Sunday"
82 longWeekDayName n = error ("longWeekDayName: invalid week day: " ⧺ show n)
84 longWeekDayNameP ∷ Num n ⇒ Parser n
85 {-# INLINEABLE longWeekDayNameP #-}
87 = choice [ string "Monday" ≫ return 1
89 ≫ choice [ string "uesday" ≫ return 2
90 , string "hursday" ≫ return 4
92 , string "Wednesday" ≫ return 3
93 , string "Friday" ≫ return 5
95 ≫ choice [ string "aturday" ≫ return 6
96 , string "unday" ≫ return 7
100 shortMonthName ∷ Num n ⇒ n → String
101 {-# INLINEABLE shortMonthName #-}
102 shortMonthName 1 = "Jan"
103 shortMonthName 2 = "Feb"
104 shortMonthName 3 = "Mar"
105 shortMonthName 4 = "Apr"
106 shortMonthName 5 = "May"
107 shortMonthName 6 = "Jun"
108 shortMonthName 7 = "Jul"
109 shortMonthName 8 = "Aug"
110 shortMonthName 9 = "Sep"
111 shortMonthName 10 = "Oct"
112 shortMonthName 11 = "Nov"
113 shortMonthName 12 = "Dec"
114 shortMonthName n = error ("shortMonthName: invalid month: " ⧺ show n)
116 shortMonthNameP ∷ Num n ⇒ Parser n
117 {-# INLINEABLE shortMonthNameP #-}
120 ≫ choice [ string "an" ≫ return 1
122 ≫ choice [ char 'n' ≫ return 6
123 , char 'l' ≫ return 7
126 , string "Feb" ≫ return 2
128 ≫ choice [ char 'r' ≫ return 3
129 , char 'y' ≫ return 5
132 ≫ choice [ string "pr" ≫ return 4
133 , string "ug" ≫ return 8
135 , string "Sep" ≫ return 9
136 , string "Oct" ≫ return 10
137 , string "Nov" ≫ return 11
138 , string "Dec" ≫ return 12
141 longMonthName ∷ Num n ⇒ n → String
142 {-# INLINEABLE longMonthName #-}
143 longMonthName 1 = "January"
144 longMonthName 2 = "February"
145 longMonthName 3 = "March"
146 longMonthName 4 = "April"
147 longMonthName 5 = "May"
148 longMonthName 6 = "June"
149 longMonthName 7 = "July"
150 longMonthName 8 = "August"
151 longMonthName 9 = "September"
152 longMonthName 10 = "October"
153 longMonthName 11 = "November"
154 longMonthName 12 = "December"
155 longMonthName n = error ("longMonthName: invalid month: " ⧺ show n)
157 longMonthNameP ∷ Num n ⇒ Parser n
158 {-# INLINEABLE longMonthNameP #-}
161 ≫ choice [ string "anuary" ≫ return 1
163 ≫ choice [ string "ne" ≫ return 6
164 , string "ly" ≫ return 7
167 , string "February" ≫ return 2
169 ≫ choice [ string "rch" ≫ return 3
170 , char 'y' ≫ return 5
173 ≫ choice [ string "pril" ≫ return 4
174 , string "ugust" ≫ return 8
176 , string "September" ≫ return 9
177 , string "October" ≫ return 10
178 , string "November" ≫ return 11
179 , string "December" ≫ return 12
182 show4 ∷ Integral i ⇒ i → AsciiBuilder
184 show4 = A.unsafeFromBuilder ∘ go
186 {-# INLINEABLE go #-}
187 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i
188 | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i
189 | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i
190 | i ≥ 0 ∧ i < 10000 = BT.integral i
191 | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)
193 show2 ∷ Integral i ⇒ i → AsciiBuilder
195 show2 = A.unsafeFromBuilder ∘ go
197 go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i
198 | i ≥ 0 ∧ i < 100 = BT.integral i
199 | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)
201 read4 ∷ Num n ⇒ Parser n
202 {-# INLINEABLE read4 #-}
203 read4 = do n1 ← digit'
207 return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
209 read2 ∷ Num n ⇒ Parser n
210 {-# INLINEABLE read2 #-}
211 read2 = do n1 ← digit'
213 return (n1 * 10 + n2)
215 digit' ∷ Num n ⇒ Parser n
216 digit' = fromC <$> P.digit
218 fromC ∷ Num n ⇒ Char → n
231 show4digitsTZ ∷ TimeZone → AsciiBuilder
233 = case timeZoneMinutes tz of
234 offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset)
235 | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset
238 = let h = offset `div` 60
243 read4digitsTZ ∷ Parser TimeZone
245 = do sign ← (char '+' ≫ return 1)
247 (char '-' ≫ return (-1))
251 timeZoneMinutes = sign * (hour * 60 + minute)
252 , timeZoneSummerOnly = False
253 , timeZoneName = timeZoneOffsetString tz
257 assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m ()
258 {-# INLINEABLE assertWeekDayIsGood #-}
259 assertWeekDayIsGood givenWD gregDay
260 = let (_, _, correctWD ) = toWeekDate gregDay
261 (year, month, day) = toGregorian gregDay
263 unless (givenWD ≡ correctWD)
265 $ concat [ "Gregorian day "
272 , longWeekDayName correctWD
274 , longWeekDayName givenWD
277 assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day
278 {-# INLINEABLE assertGregorianDateIsGood #-}
279 assertGregorianDateIsGood year month day
280 = case fromGregorianValid year month day of
282 → fail $ concat [ "Invalid gregorian day: "
292 assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay
293 {-# INLINEABLE assertTimeOfDayIsGood #-}
294 assertTimeOfDayIsGood hour minute second
295 = case makeTimeOfDayValid hour minute second of
297 → fail $ concat [ "Invalid time of day: "
302 , showFixed True second