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