Data/Time/HTTP/Common.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 module Data.Time.HTTP.Common
   3     ( shortWeekDayName
   4     , shortWeekDayNameP
   5
   6     , longWeekDayName
   7     , longWeekDayNameP
   8
   9     , shortMonthName
  10     , shortMonthNameP
  11
  12     , longMonthName
  13     , longMonthNameP
  14
  15     , show2
  16     , show4
  17
  18     , read2
  19     , read4
  20
  21     , showTZ
  22     , read4digitsTZ
  23
  24     , assertWeekDayIsGood
  25     , assertGregorianDateIsGood
  26     , assertTimeOfDayIsGood
  27     )
  28     where
  29
  30 import Control.Monad
  31 import Data.Fixed
  32 import Data.Time
  33 import Data.Time.Calendar.WeekDate
  34 import Text.Parsec
  35
  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)
  45
  46 shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int
  47 shortWeekDayNameP
  48     = choice [ string "Mon" >> return 1
  49              , char 'T'
  50                >> choice [ string "ue" >> return 2
  51                          , string "hu" >> return 4
  52                          ]
  53              , string "Wed" >> return 3
  54              , string "Fri" >> return 5
  55              , char 'S'
  56                >> choice [ string "at" >> return 6
  57                          , string "un" >> return 7
  58                          ]
  59              ]
  60
  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"
  69
  70 longWeekDayNameP :: Stream s m Char => ParsecT s u m Int
  71 longWeekDayNameP
  72     = choice [ string "Monday" >> return 1
  73              , char 'T'
  74                >> choice [ string "uesday"  >> return 2
  75                          , string "hursday" >> return 4
  76                          ]
  77              , string "Wednesday" >> return 3
  78              , string "Friday"    >> return 5
  79              , char 'S'
  80                >> choice [ string "aturday" >> return 6
  81                          , string "unday"   >> return 7
  82                          ]
  83              ]
  84
  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)
  99
 100 shortMonthNameP :: Stream s m Char => ParsecT s u m Int
 101 shortMonthNameP
 102     = choice [ char 'J'
 103                >> choice [ string "an" >> return 1
 104                          , char 'u'
 105                            >> choice [ char 'n' >> return 6
 106                                      , char 'l' >> return 7
 107                                      ]
 108                          ]
 109              , string "Feb" >> return 2
 110              , string "Ma"
 111                >> choice [ char 'r' >> return 3
 112                          , char 'y' >> return 5
 113                          ]
 114              , char 'A'
 115                >> choice [ string "pr" >> return 4
 116                          , string "ug" >> return 8
 117                          ]
 118              , string "Sep" >> return 9
 119              , string "Oct" >> return 10
 120              , string "Nov" >> return 11
 121              , string "Dec" >> return 12
 122              ]
 123
 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)
 138
 139 longMonthNameP :: Stream s m Char => ParsecT s u m Int
 140 longMonthNameP
 141     = choice [ char 'J'
 142                >> choice [ string "anuary" >> return 1
 143                          , char 'u'
 144                            >> choice [ string "ne" >> return 6
 145                                      , string "ly" >> return 7
 146                                      ]
 147                          ]
 148              , string "February" >> return 2
 149              , string "Ma"
 150                >> choice [ string "rch" >> return 3
 151                          , char 'y' >> return 5
 152                          ]
 153              , char 'A'
 154                >> choice [ string "pril" >> return 4
 155                          , string "ugust" >> return 8
 156                          ]
 157              , string "September" >> return 9
 158              , string "October"   >> return 10
 159              , string "November"  >> return 11
 160              , string "December"  >> return 12
 161              ]
 162
 163 show4 :: Integral i => i -> String
 164 show4 i
 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)
 170
 171 show2 :: Integral i => i -> String
 172 show2 i
 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)
 176
 177 read4 :: (Stream s m Char, Num n) => ParsecT s u m n
 178 read4 = do n1 <- digit'
 179            n2 <- digit'
 180            n3 <- digit'
 181            n4 <- digit'
 182            return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
 183
 184 read2 :: (Stream s m Char, Num n) => ParsecT s u m n
 185 read2 = do n1 <- digit'
 186            n2 <- digit'
 187            return (n1 * 10 + n2)
 188
 189 digit' :: (Stream s m Char, Num n) => ParsecT s u m n
 190 digit' = liftM fromC digit
 191
 192 fromC :: Num n => Char -> n
 193 fromC '0' = 0
 194 fromC '1' = 1
 195 fromC '2' = 2
 196 fromC '3' = 3
 197 fromC '4' = 4
 198 fromC '5' = 5
 199 fromC '6' = 6
 200 fromC '7' = 7
 201 fromC '8' = 8
 202 fromC '9' = 9
 203 fromC _   = undefined
 204
 205 showTZ :: TimeZone -> String
 206 showTZ tz
 207     = case timeZoneMinutes tz of
 208         offset | offset <  0 -> '-' : showTZ' (negate offset)
 209                | otherwise   -> '+' : showTZ' offset
 210     where
 211       showTZ' offset
 212           = let h = offset `div` 60
 213                 m = offset - h * 60
 214             in
 215               concat [show2 h, show2 m]
 216
 217 read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone
 218 read4digitsTZ
 219     = do sign   <- (char '+' >> return 1)
 220                    <|>
 221                    (char '-' >> return (-1))
 222          hour   <- read2
 223          minute <- read2
 224          let tz = TimeZone {
 225                     timeZoneMinutes    = (sign * (hour * 60 + minute))
 226                   , timeZoneSummerOnly = False
 227                   , timeZoneName       = timeZoneOffsetString tz
 228                   }
 229          return tz
 230
 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
 235       in
 236         unless (givenWD == correctWD)
 237                    $ fail
 238                    $ concat [ "Gregorian day "
 239                             , show year
 240                             , "-"
 241                             , show month
 242                             , "-"
 243                             , show day
 244                             , " is "
 245                             , longWeekDayName correctWD
 246                             , ", not "
 247                             , longWeekDayName givenWD
 248                             ]
 249
 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
 253         Nothing
 254             -> fail $ concat [ "Invalid gregorian day: "
 255                              , show year
 256                              , "-"
 257                              , show month
 258                              , "-"
 259                              , show day
 260                              ]
 261         Just gregDay
 262             -> return gregDay
 263
 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
 267         Nothing
 268             -> fail $ concat [ "Invalid time of day: "
 269                              , show hour
 270                              , ":"
 271                              , show minute
 272                              , ":"
 273                              , showFixed True second
 274                              ]
 275         Just tod
 276             -> return tod