1 {-# LANGUAGE FlexibleContexts #-}
2 module Data.Time.HTTP.Common
25 , assertGregorianDateIsGood
26 , assertTimeOfDayIsGood
33 import Data.Time.Calendar.WeekDate
36 shortWeekDayName :: Int -> String
37 shortWeekDayName 1 = "Mon"
38 shortWeekDayName 2 = "Tue"
39 shortWeekDayName 3 = "Wed"
40 shortWeekDayName 4 = "Thu"
41 shortWeekDayName 5 = "Fri"
42 shortWeekDayName 6 = "Sat"
43 shortWeekDayName 7 = "Sun"
44 shortWeekDayName n = error ("shortWeekDayName: unknown day number: " ++ show n)
46 shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int
48 = choice [ string "Mon" >> return 1
50 >> choice [ string "ue" >> return 2
51 , string "hu" >> return 4
53 , string "Wed" >> return 3
54 , string "Fri" >> return 5
56 >> choice [ string "at" >> return 6
57 , string "un" >> return 7
61 longWeekDayName :: Int -> String
62 longWeekDayName 1 = "Monday"
63 longWeekDayName 2 = "Tuesday"
64 longWeekDayName 3 = "Wednesday"
65 longWeekDayName 4 = "Thursday"
66 longWeekDayName 5 = "Friday"
67 longWeekDayName 6 = "Saturday"
68 longWeekDayName 7 = "Sunday"
70 longWeekDayNameP :: Stream s m Char => ParsecT s u m Int
72 = choice [ string "Monday" >> return 1
74 >> choice [ string "uesday" >> return 2
75 , string "hursday" >> return 4
77 , string "Wednesday" >> return 3
78 , string "Friday" >> return 5
80 >> choice [ string "aturday" >> return 6
81 , string "unday" >> return 7
85 shortMonthName :: Int -> String
86 shortMonthName 1 = "Jan"
87 shortMonthName 2 = "Feb"
88 shortMonthName 3 = "Mar"
89 shortMonthName 4 = "Apr"
90 shortMonthName 5 = "May"
91 shortMonthName 6 = "Jun"
92 shortMonthName 7 = "Jul"
93 shortMonthName 8 = "Aug"
94 shortMonthName 9 = "Sep"
95 shortMonthName 10 = "Oct"
96 shortMonthName 11 = "Nov"
97 shortMonthName 12 = "Dec"
98 shortMonthName n = error ("shortMonthName: unknown month number: " ++ show n)
100 shortMonthNameP :: Stream s m Char => ParsecT s u m Int
103 >> choice [ string "an" >> return 1
105 >> choice [ char 'n' >> return 6
106 , char 'l' >> return 7
109 , string "Feb" >> return 2
111 >> choice [ char 'r' >> return 3
112 , char 'y' >> return 5
115 >> choice [ string "pr" >> return 4
116 , string "ug" >> return 8
118 , string "Sep" >> return 9
119 , string "Oct" >> return 10
120 , string "Nov" >> return 11
121 , string "Dec" >> return 12
124 longMonthName :: Int -> String
125 longMonthName 1 = "January"
126 longMonthName 2 = "February"
127 longMonthName 3 = "March"
128 longMonthName 4 = "April"
129 longMonthName 5 = "May"
130 longMonthName 6 = "June"
131 longMonthName 7 = "July"
132 longMonthName 8 = "August"
133 longMonthName 9 = "September"
134 longMonthName 10 = "October"
135 longMonthName 11 = "November"
136 longMonthName 12 = "December"
137 longMonthName n = error ("longMonthName: unknown month number: " ++ show n)
139 longMonthNameP :: Stream s m Char => ParsecT s u m Int
142 >> choice [ string "anuary" >> return 1
144 >> choice [ string "ne" >> return 6
145 , string "ly" >> return 7
148 , string "February" >> return 2
150 >> choice [ string "rch" >> return 3
151 , char 'y' >> return 5
154 >> choice [ string "pril" >> return 4
155 , string "ugust" >> return 8
157 , string "September" >> return 9
158 , string "October" >> return 10
159 , string "November" >> return 11
160 , string "December" >> return 12
163 show4 :: Integral i => i -> String
165 | i >= 0 && i < 10 = "000" ++ show i
166 | i >= 0 && i < 100 = "00" ++ show i
167 | i >= 0 && i < 1000 = "0" ++ show i
168 | i >= 0 && i < 10000 = show i
169 | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ++ show i)
171 show2 :: Integral i => i -> String
173 | i >= 0 && i < 10 = "0" ++ show i
174 | i >= 0 && i < 100 = show i
175 | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ++ show i)
177 read4 :: (Stream s m Char, Num n) => ParsecT s u m n
178 read4 = do n1 <- digit'
182 return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
184 read2 :: (Stream s m Char, Num n) => ParsecT s u m n
185 read2 = do n1 <- digit'
187 return (n1 * 10 + n2)
189 digit' :: (Stream s m Char, Num n) => ParsecT s u m n
190 digit' = liftM fromC digit
192 fromC :: Num n => Char -> n
205 show4digitsTZ :: TimeZone -> String
207 = case timeZoneMinutes tz of
208 offset | offset < 0 -> '-' : showTZ' (negate offset)
209 | otherwise -> '+' : showTZ' offset
212 = let h = offset `div` 60
215 concat [show2 h, show2 m]
217 read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone
219 = do sign <- (char '+' >> return 1)
221 (char '-' >> return (-1))
225 timeZoneMinutes = (sign * (hour * 60 + minute))
226 , timeZoneSummerOnly = False
227 , timeZoneName = timeZoneOffsetString tz
231 assertWeekDayIsGood :: Stream s m t => Int -> Day -> ParsecT s u m ()
232 assertWeekDayIsGood givenWD gregDay
233 = let (_, _, correctWD ) = toWeekDate gregDay
234 (year, month, day) = toGregorian gregDay
236 unless (givenWD == correctWD)
238 $ concat [ "Gregorian day "
245 , longWeekDayName correctWD
247 , longWeekDayName givenWD
250 assertGregorianDateIsGood :: Stream s m t => Integer -> Int -> Int -> ParsecT s u m Day
251 assertGregorianDateIsGood year month day
252 = case fromGregorianValid year month day of
254 -> fail $ concat [ "Invalid gregorian day: "
264 assertTimeOfDayIsGood :: Stream s m t => Int -> Int -> Pico -> ParsecT s u m TimeOfDay
265 assertTimeOfDayIsGood hour minute second
266 = case makeTimeOfDayValid hour minute second of
268 -> fail $ concat [ "Invalid time of day: "
273 , showFixed True second