Data/Time/HTTP/Common.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 module Data.Time.HTTP.Common
   6     ( shortWeekDayName
   7     , shortWeekDayNameP
   8
   9     , longWeekDayName
  10     , longWeekDayNameP
  11
  12     , shortMonthName
  13     , shortMonthNameP
  14
  15     , longMonthName
  16     , longMonthNameP
  17
  18     , show4
  19     , show2
  20     , show2'
  21
  22     , read4
  23     , read2
  24     , read2'
  25
  26     , show4digitsTZ
  27     , read4digitsTZ
  28
  29     , assertWeekDayIsGood
  30     , assertGregorianDateIsGood
  31     , assertTimeOfDayIsGood
  32
  33     , optionMaybe
  34     )
  35     where
  36 import Blaze.ByteString.Builder.ByteString as B
  37 import Blaze.Text.Int as BT
  38 import Control.Applicative
  39 import Control.Monad
  40 import Data.Ascii (AsciiBuilder)
  41 import qualified Data.Ascii as A
  42 import Data.Attoparsec.Char8 as P
  43 import Data.Monoid.Unicode
  44 import Data.Fixed
  45 import Data.Time
  46 import Data.Time.Calendar.WeekDate
  47 import Prelude.Unicode
  48
  49 shortWeekDayName ∷ Num n ⇒ n → AsciiBuilder
  50 {-# INLINE shortWeekDayName #-}
  51 shortWeekDayName = A.toAsciiBuilder ∘ go
  52     where
  53       {-# INLINEABLE go #-}
  54       go 1 = "Mon"
  55       go 2 = "Tue"
  56       go 3 = "Wed"
  57       go 4 = "Thu"
  58       go 5 = "Fri"
  59       go 6 = "Sat"
  60       go 7 = "Sun"
  61       go n = error ("shortWeekDayName: invalid week day: " ⧺ show n)
  62
  63 shortWeekDayNameP ∷ Num n ⇒ Parser n
  64 {-# INLINEABLE shortWeekDayNameP #-}
  65 shortWeekDayNameP
  66     = choice [ string "Mon" *> return 1
  67              , char 'T'
  68                *> choice [ string "ue" *> return 2
  69                          , string "hu" *> return 4
  70                          ]
  71              , string "Wed" *> return 3
  72              , string "Fri" *> return 5
  73              , char 'S'
  74                *> choice [ string "at" *> return 6
  75                          , string "un" *> return 7
  76                          ]
  77              ]
  78
  79 longWeekDayName ∷ Num n ⇒ n → AsciiBuilder
  80 {-# INLINE longWeekDayName #-}
  81 longWeekDayName = A.toAsciiBuilder ∘ go
  82     where
  83       {-# INLINEABLE go #-}
  84       go 1 = "Monday"
  85       go 2 = "Tuesday"
  86       go 3 = "Wednesday"
  87       go 4 = "Thursday"
  88       go 5 = "Friday"
  89       go 6 = "Saturday"
  90       go 7 = "Sunday"
  91       go n = error ("longWeekDayName: invalid week day: " ⧺ show n)
  92
  93 longWeekDayNameP ∷ Num n ⇒ Parser n
  94 {-# INLINEABLE longWeekDayNameP #-}
  95 longWeekDayNameP
  96     = choice [ string "Monday" *> return 1
  97              , char 'T'
  98                *> choice [ string "uesday"  *> return 2
  99                          , string "hursday" *> return 4
 100                          ]
 101              , string "Wednesday" *> return 3
 102              , string "Friday"    *> return 5
 103              , char 'S'
 104                *> choice [ string "aturday" *> return 6
 105                          , string "unday"   *> return 7
 106                          ]
 107              ]
 108
 109 shortMonthName ∷ Num n ⇒ n → AsciiBuilder
 110 {-# INLINE shortMonthName #-}
 111 shortMonthName = A.toAsciiBuilder ∘ go
 112     where
 113       {-# INLINEABLE go #-}
 114       go  1 = "Jan"
 115       go  2 = "Feb"
 116       go  3 = "Mar"
 117       go  4 = "Apr"
 118       go  5 = "May"
 119       go  6 = "Jun"
 120       go  7 = "Jul"
 121       go  8 = "Aug"
 122       go  9 = "Sep"
 123       go 10 = "Oct"
 124       go 11 = "Nov"
 125       go 12 = "Dec"
 126       go  n = error ("shortMonthName: invalid month: " ⧺ show n)
 127
 128 shortMonthNameP ∷ Num n ⇒ Parser n
 129 {-# INLINEABLE shortMonthNameP #-}
 130 shortMonthNameP
 131     = choice [ char 'J'
 132                *> choice [ string "an" *> return 1
 133                          , char 'u'
 134                            *> choice [ char 'n' *> return 6
 135                                      , char 'l' *> return 7
 136                                      ]
 137                          ]
 138              , string "Feb" *> return 2
 139              , string "Ma"
 140                *> choice [ char 'r' *> return 3
 141                          , char 'y' *> return 5
 142                          ]
 143              , char 'A'
 144                *> choice [ string "pr" *> return 4
 145                          , string "ug" *> return 8
 146                          ]
 147              , string "Sep" *> return 9
 148              , string "Oct" *> return 10
 149              , string "Nov" *> return 11
 150              , string "Dec" *> return 12
 151              ]
 152
 153 longMonthName ∷ Num n ⇒ n → AsciiBuilder
 154 {-# INLINE longMonthName #-}
 155 longMonthName = A.toAsciiBuilder ∘ go
 156     where
 157       {-# INLINEABLE go #-}
 158       go  1 = "January"
 159       go  2 = "February"
 160       go  3 = "March"
 161       go  4 = "April"
 162       go  5 = "May"
 163       go  6 = "June"
 164       go  7 = "July"
 165       go  8 = "August"
 166       go  9 = "September"
 167       go 10 = "October"
 168       go 11 = "November"
 169       go 12 = "December"
 170       go  n = error ("longMonthName: invalid month: " ⧺ show n)
 171
 172 longMonthNameP ∷ Num n ⇒ Parser n
 173 {-# INLINEABLE longMonthNameP #-}
 174 longMonthNameP
 175     = choice [ char 'J'
 176                *> choice [ string "anuary" *> return 1
 177                          , char 'u'
 178                            *> choice [ string "ne" *> return 6
 179                                      , string "ly" *> return 7
 180                                      ]
 181                          ]
 182              , string "February" *> return 2
 183              , string "Ma"
 184                *> choice [ string "rch" *> return 3
 185                          , char 'y' *> return 5
 186                          ]
 187              , char 'A'
 188                *> choice [ string "pril" *> return 4
 189                          , string "ugust" *> return 8
 190                          ]
 191              , string "September" *> return 9
 192              , string "October"   *> return 10
 193              , string "November"  *> return 11
 194              , string "December"  *> return 12
 195              ]
 196
 197 show4 ∷ Integral i ⇒ i → AsciiBuilder
 198 {-# INLINE show4 #-}
 199 show4 = A.unsafeFromBuilder ∘ go
 200     where
 201       {-# INLINEABLE go #-}
 202       go i | i ≥ 0 ∧ i < 10    = B.fromByteString "000" ⊕ BT.digit    i
 203            | i ≥ 0 ∧ i < 100   = B.fromByteString "00"  ⊕ BT.integral i
 204            | i ≥ 0 ∧ i < 1000  = B.fromByteString "0"   ⊕ BT.integral i
 205            | i ≥ 0 ∧ i < 10000 =                          BT.integral i
 206            | otherwise         = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)
 207
 208 show2 ∷ Integral i ⇒ i → AsciiBuilder
 209 {-# INLINE show2 #-}
 210 show2 = A.unsafeFromBuilder ∘ go
 211     where
 212       go i | i ≥ 0 ∧ i < 10  = B.fromByteString "0" ⊕ BT.digit    i
 213            | i ≥ 0 ∧ i < 100 =                        BT.integral i
 214            | otherwise       = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)
 215
 216 show2' ∷ Integral i ⇒ i → AsciiBuilder
 217 {-# INLINE show2' #-}
 218 show2' = A.unsafeFromBuilder ∘ go
 219     where
 220       go i | i ≥ 0 ∧ i < 10  = B.fromByteString " " ⊕ BT.digit    i
 221            | i ≥ 0 ∧ i < 100 =                        BT.integral i
 222            | otherwise       = error ("show2': the integer i must satisfy 0 <= i < 100: " ⧺ show i)
 223
 224 read4 ∷ Num n ⇒ Parser n
 225 {-# INLINEABLE read4 #-}
 226 read4 = do n1 ← digit'
 227            n2 ← digit'
 228            n3 ← digit'
 229            n4 ← digit'
 230            return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)
 231
 232 read2 ∷ Num n ⇒ Parser n
 233 {-# INLINEABLE read2 #-}
 234 read2 = do n1 ← digit'
 235            n2 ← digit'
 236            return (n1 * 10 + n2)
 237
 238 read2' ∷ Num n ⇒ Parser n
 239 {-# INLINEABLE read2' #-}
 240 read2' = do n1 ← (char ' ' *> pure 0) <|> digit'
 241             n2 ← digit'
 242             return (n1 * 10 + n2)
 243
 244 digit' ∷ Num n ⇒ Parser n
 245 digit' = fromC <$> P.digit
 246
 247 fromC ∷ Num n ⇒ Char → n
 248 fromC '0' = 0
 249 fromC '1' = 1
 250 fromC '2' = 2
 251 fromC '3' = 3
 252 fromC '4' = 4
 253 fromC '5' = 5
 254 fromC '6' = 6
 255 fromC '7' = 7
 256 fromC '8' = 8
 257 fromC '9' = 9
 258 fromC _   = undefined
 259
 260 show4digitsTZ ∷ TimeZone → AsciiBuilder
 261 show4digitsTZ tz
 262     = case timeZoneMinutes tz of
 263         offset | offset <  0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset)
 264                | otherwise   → A.toAsciiBuilder "+" ⊕ showTZ' offset
 265     where
 266       showTZ' offset
 267           = let h = offset `div` 60
 268                 m = offset - h * 60
 269             in
 270               show2 h ⊕ show2 m
 271
 272 read4digitsTZ ∷ Parser TimeZone
 273 read4digitsTZ
 274     = do sign   ← (char '+' *> return 1)
 275                   <|>
 276                   (char '-' *> return (-1))
 277          hour   ← read2
 278          minute ← read2
 279          let tz = TimeZone {
 280                     timeZoneMinutes    = sign * (hour * 60 + minute)
 281                   , timeZoneSummerOnly = False
 282                   , timeZoneName       = timeZoneOffsetString tz
 283                   }
 284          return tz
 285
 286 assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m ()
 287 {-# INLINEABLE assertWeekDayIsGood #-}
 288 assertWeekDayIsGood givenWD gregDay
 289     = let (_, _, correctWD ) = toWeekDate  gregDay
 290           (year, month, day) = toGregorian gregDay
 291       in
 292         unless (givenWD ≡ correctWD)
 293             $ fail
 294             $ concat [ "Gregorian day "
 295                      , show year
 296                      , "-"
 297                      , show month
 298                      , "-"
 299                      , show day
 300                      , " is "
 301                      , toStr $ longWeekDayName correctWD
 302                      , ", not "
 303                      , toStr $ longWeekDayName givenWD
 304                      ]
 305     where
 306       toStr ∷ AsciiBuilder → String
 307       toStr = A.toString ∘ A.fromAsciiBuilder
 308
 309 assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day
 310 {-# INLINEABLE assertGregorianDateIsGood #-}
 311 assertGregorianDateIsGood year month day
 312     = case fromGregorianValid year month day of
 313         Nothing
 314             → fail $ concat [ "Invalid gregorian day: "
 315                             , show year
 316                             , "-"
 317                             , show month
 318                             , "-"
 319                             , show day
 320                             ]
 321         Just gregDay
 322             → return gregDay
 323
 324 assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay
 325 {-# INLINEABLE assertTimeOfDayIsGood #-}
 326 assertTimeOfDayIsGood hour minute second
 327     = case makeTimeOfDayValid hour minute second of
 328         Nothing
 329             → fail $ concat [ "Invalid time of day: "
 330                             , show hour
 331                             , ":"
 332                             , show minute
 333                             , ":"
 334                             , showFixed True second
 335                             ]
 336         Just tod
 337             → return tod
 338
 339 optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a)
 340 {-# INLINE optionMaybe #-}
 341 optionMaybe p
 342     = option Nothing (Just <$> p)