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