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