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     , show4digitsTZ
  22     , read4digitsTZ
  23
  24     , assertWeekDayIsGood
  25     , assertGregorianDateIsGood
  26     , assertTimeOfDayIsGood
  27     )
  28     where
  29 import Control.Monad
  30 import Data.Fixed
  31 import Data.Time
  32 import Data.Time.Calendar.WeekDate
  33
  34 shortWeekDayName :: Int -> String
  35 shortWeekDayName 1 = "Mon"
  36 shortWeekDayName 2 = "Tue"
  37 shortWeekDayName 3 = "Wed"
  38 shortWeekDayName 4 = "Thu"
  39 shortWeekDayName 5 = "Fri"
  40 shortWeekDayName 6 = "Sat"
  41 shortWeekDayName 7 = "Sun"
  42 shortWeekDayName n = error ("shortWeekDayName: unknown day number: " ++ show n)
  43
  44 shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int
  45 shortWeekDayNameP
  46     = choice [ string "Mon" >> return 1
  47              , char 'T'
  48                >> choice [ string "ue" >> return 2
  49                          , string "hu" >> return 4
  50                          ]
  51              , string "Wed" >> return 3
  52              , string "Fri" >> return 5
  53              , char 'S'
  54                >> choice [ string "at" >> return 6
  55                          , string "un" >> return 7
  56                          ]
  57              ]
  58
  59 longWeekDayName :: Int -> String
  60 longWeekDayName 1 = "Monday"
  61 longWeekDayName 2 = "Tuesday"
  62 longWeekDayName 3 = "Wednesday"
  63 longWeekDayName 4 = "Thursday"
  64 longWeekDayName 5 = "Friday"
  65 longWeekDayName 6 = "Saturday"
  66 longWeekDayName 7 = "Sunday"
  67
  68 longWeekDayNameP :: Stream s m Char => ParsecT s u m Int
  69 longWeekDayNameP
  70     = choice [ string "Monday" >> return 1
  71              , char 'T'
  72                >> choice [ string "uesday"  >> return 2
  73                          , string "hursday" >> return 4
  74                          ]
  75              , string "Wednesday" >> return 3
  76              , string "Friday"    >> return 5
  77              , char 'S'
  78                >> choice [ string "aturday" >> return 6
  79                          , string "unday"   >> return 7
  80                          ]
  81              ]
  82
  83 shortMonthName :: Int -> String
  84 shortMonthName  1 = "Jan"
  85 shortMonthName  2 = "Feb"
  86 shortMonthName  3 = "Mar"
  87 shortMonthName  4 = "Apr"
  88 shortMonthName  5 = "May"
  89 shortMonthName  6 = "Jun"
  90 shortMonthName  7 = "Jul"
  91 shortMonthName  8 = "Aug"
  92 shortMonthName  9 = "Sep"
  93 shortMonthName 10 = "Oct"
  94 shortMonthName 11 = "Nov"
  95 shortMonthName 12 = "Dec"
  96 shortMonthName  n = error ("shortMonthName: unknown month number: " ++ show n)
  97
  98 shortMonthNameP :: Stream s m Char => ParsecT s u m Int
  99 shortMonthNameP
 100     = choice [ char 'J'
 101                >> choice [ string "an" >> return 1
 102                          , char 'u'
 103                            >> choice [ char 'n' >> return 6
 104                                      , char 'l' >> return 7
 105                                      ]
 106                          ]
 107              , string "Feb" >> return 2
 108              , string "Ma"
 109                >> choice [ char 'r' >> return 3
 110                          , char 'y' >> return 5
 111                          ]
 112              , char 'A'
 113                >> choice [ string "pr" >> return 4
 114                          , string "ug" >> return 8
 115                          ]
 116              , string "Sep" >> return 9
 117              , string "Oct" >> return 10
 118              , string "Nov" >> return 11
 119              , string "Dec" >> return 12
 120              ]
 121
 122 longMonthName :: Int -> String
 123 longMonthName  1 = "January"
 124 longMonthName  2 = "February"
 125 longMonthName  3 = "March"
 126 longMonthName  4 = "April"
 127 longMonthName  5 = "May"
 128 longMonthName  6 = "June"
 129 longMonthName  7 = "July"
 130 longMonthName  8 = "August"
 131 longMonthName  9 = "September"
 132 longMonthName 10 = "October"
 133 longMonthName 11 = "November"
 134 longMonthName 12 = "December"
 135 longMonthName  n = error ("longMonthName: unknown month number: " ++ show n)
 136
 137 longMonthNameP :: Stream s m Char => ParsecT s u m Int
 138 longMonthNameP
 139     = choice [ char 'J'
 140                >> choice [ string "anuary" >> return 1
 141                          , char 'u'
 142                            >> choice [ string "ne" >> return 6
 143                                      , string "ly" >> return 7
 144                                      ]
 145                          ]
 146              , string "February" >> return 2
 147              , string "Ma"
 148                >> choice [ string "rch" >> return 3
 149                          , char 'y' >> return 5
 150                          ]
 151              , char 'A'
 152                >> choice [ string "pril" >> return 4
 153                          , string "ugust" >> return 8
 154                          ]
 155              , string "September" >> return 9
 156              , string "October"   >> return 10
 157              , string "November"  >> return 11
 158              , string "December"  >> return 12
 159              ]
 160
 161 show4 :: Integral i => i -> String
 162 show4 i
 163     | i >= 0 && i < 10    = "000" ++ show i
 164     | i >= 0 && i < 100   = "00"  ++ show i
 165     | i >= 0 && i < 1000  = '0'    : show i
 166     | i >= 0 && i < 10000 = show i
 167     | otherwise          = error ("show4: the integer i must satisfy 0 <= i < 10000: " ++ show i)
 168
 169 show2 :: Integral i => i -> String
 170 show2 i
 171     | i >= 0 && i < 10  = '0' : show i
 172     | i >= 0 && i < 100 = show i
 173     | otherwise         = error ("show2: the integer i must satisfy 0 <= i < 100: " ++ show i)
 174
 175 read4 :: (Stream s m Char, Num n) => ParsecT s u m n
 176 read4 = do n1 <- digit'
 177            n2 <- digit'
 178            n3 <- digit'
 179            n4 <- digit'
 180            return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
 181
 182 read2 :: (Stream s m Char, Num n) => ParsecT s u m n
 183 read2 = do n1 <- digit'
 184            n2 <- digit'
 185            return (n1 * 10 + n2)
 186
 187 digit' :: (Stream s m Char, Num n) => ParsecT s u m n
 188 digit' = liftM fromC digit
 189
 190 fromC :: Num n => Char -> n
 191 fromC '0' = 0
 192 fromC '1' = 1
 193 fromC '2' = 2
 194 fromC '3' = 3
 195 fromC '4' = 4
 196 fromC '5' = 5
 197 fromC '6' = 6
 198 fromC '7' = 7
 199 fromC '8' = 8
 200 fromC '9' = 9
 201 fromC _   = undefined
 202
 203 show4digitsTZ :: TimeZone -> String
 204 show4digitsTZ tz
 205     = case timeZoneMinutes tz of
 206         offset | offset <  0 -> '-' : showTZ' (negate offset)
 207                | otherwise   -> '+' : showTZ' offset
 208     where
 209       showTZ' offset
 210           = let h = offset `div` 60
 211                 m = offset - h * 60
 212             in
 213               show2 h ++ show2 m
 214
 215 read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone
 216 read4digitsTZ
 217     = do sign   <- (char '+' >> return 1)
 218                    <|>
 219                    (char '-' >> return (-1))
 220          hour   <- read2
 221          minute <- read2
 222          let tz = TimeZone {
 223                     timeZoneMinutes    = sign * (hour * 60 + minute)
 224                   , timeZoneSummerOnly = False
 225                   , timeZoneName       = timeZoneOffsetString tz
 226                   }
 227          return tz
 228
 229 assertWeekDayIsGood :: Stream s m t => Int -> Day -> ParsecT s u m ()
 230 assertWeekDayIsGood givenWD gregDay
 231     = let (_, _, correctWD ) = toWeekDate  gregDay
 232           (year, month, day) = toGregorian gregDay
 233       in
 234         unless (givenWD == correctWD)
 235                    $ fail
 236                    $ concat [ "Gregorian day "
 237                             , show year
 238                             , "-"
 239                             , show month
 240                             , "-"
 241                             , show day
 242                             , " is "
 243                             , longWeekDayName correctWD
 244                             , ", not "
 245                             , longWeekDayName givenWD
 246                             ]
 247
 248 assertGregorianDateIsGood :: Stream s m t => Integer -> Int -> Int -> ParsecT s u m Day
 249 assertGregorianDateIsGood year month day
 250     = case fromGregorianValid year month day of
 251         Nothing
 252             -> fail $ concat [ "Invalid gregorian day: "
 253                              , show year
 254                              , "-"
 255                              , show month
 256                              , "-"
 257                              , show day
 258                              ]
 259         Just gregDay
 260             -> return gregDay
 261
 262 assertTimeOfDayIsGood :: Stream s m t => Int -> Int -> Pico -> ParsecT s u m TimeOfDay
 263 assertTimeOfDayIsGood hour minute second
 264     = case makeTimeOfDayValid hour minute second of
 265         Nothing
 266             -> fail $ concat [ "Invalid time of day: "
 267                              , show hour
 268                              , ":"
 269                              , show minute
 270                              , ":"
 271                              , showFixed True second
 272                              ]
 273         Just tod
 274             -> return tod