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