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