X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FHTTP%2FCommon.hs;h=1cfa89e9c63528268d721d309927dc58f981f586;hp=1ea61de90bc2a21cc0e85a5d41fe63225d188a34;hb=e322e3c65458dd6004ae4d2fbf5e82ce9aaee162;hpb=9f9ed0471883b50fec1b091621f332d62477a34c diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs index 1ea61de..1cfa89e 100644 --- a/Data/Time/HTTP/Common.hs +++ b/Data/Time/HTTP/Common.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module Data.Time.HTTP.Common ( shortWeekDayName , shortWeekDayNameP @@ -9,135 +12,239 @@ module Data.Time.HTTP.Common , shortMonthName , shortMonthNameP - , show2 + , longMonthName + , longMonthNameP + , show4 + , show2 + , show2' - , read2 , read4 + , read2 + , read2' + + , show4digitsTZ + , read4digitsTZ + + , assertWeekDayIsGood + , assertGregorianDateIsGood + , assertTimeOfDayIsGood + + , optionMaybe ) where - +import Blaze.ByteString.Builder.ByteString as B +import Blaze.Text.Int as BT +import Control.Applicative import Control.Monad -import Text.Parsec - -shortWeekDayName :: Int -> String -shortWeekDayName 1 = "Mon" -shortWeekDayName 2 = "Tue" -shortWeekDayName 3 = "Wed" -shortWeekDayName 4 = "Thu" -shortWeekDayName 5 = "Fri" -shortWeekDayName 6 = "Sat" -shortWeekDayName 7 = "Sun" -shortWeekDayName n = error ("shortWeekDayName: unknown day number: " ++ show n) - -shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int +import Data.Ascii (AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import Data.Monoid.Unicode +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate +import Prelude.Unicode + +shortWeekDayName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE shortWeekDayName #-} +shortWeekDayName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "Mon" + go 2 = "Tue" + go 3 = "Wed" + go 4 = "Thu" + go 5 = "Fri" + go 6 = "Sat" + go 7 = "Sun" + go n = error ("shortWeekDayName: invalid week day: " ⧺ show n) + +shortWeekDayNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE shortWeekDayNameP #-} shortWeekDayNameP - = choice [ string "Mon" >> return 1 + = choice [ string "Mon" *> return 1 , char 'T' - >> choice [ string "ue" >> return 2 - , string "hu" >> return 4 + *> choice [ string "ue" *> return 2 + , string "hu" *> return 4 ] - , string "Wed" >> return 3 - , string "Fri" >> return 5 + , string "Wed" *> return 3 + , string "Fri" *> return 5 , char 'S' - >> choice [ string "at" >> return 6 - , string "un" >> return 7 + *> choice [ string "at" *> return 6 + , string "un" *> return 7 ] ] -longWeekDayName :: Int -> String -longWeekDayName 1 = "Monday" -longWeekDayName 2 = "Tuesday" -longWeekDayName 3 = "Wednesday" -longWeekDayName 4 = "Thursday" -longWeekDayName 5 = "Friday" -longWeekDayName 6 = "Saturday" -longWeekDayName 7 = "Sunday" +longWeekDayName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE longWeekDayName #-} +longWeekDayName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "Monday" + go 2 = "Tuesday" + go 3 = "Wednesday" + go 4 = "Thursday" + go 5 = "Friday" + go 6 = "Saturday" + go 7 = "Sunday" + go n = error ("longWeekDayName: invalid week day: " ⧺ show n) -longWeekDayNameP :: Stream s m Char => ParsecT s u m Int +longWeekDayNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE longWeekDayNameP #-} longWeekDayNameP - = choice [ string "Monday" >> return 1 + = choice [ string "Monday" *> return 1 , char 'T' - >> choice [ string "uesday" >> return 2 - , string "hursday" >> return 4 + *> choice [ string "uesday" *> return 2 + , string "hursday" *> return 4 ] - , string "Wednesday" >> return 3 - , string "Friday" >> return 5 + , string "Wednesday" *> return 3 + , string "Friday" *> return 5 , char 'S' - >> choice [ string "aturday" >> return 6 - , string "unday" >> return 7 + *> choice [ string "aturday" *> return 6 + , string "unday" *> return 7 ] ] -shortMonthName :: Int -> String -shortMonthName 1 = "Jan" -shortMonthName 2 = "Feb" -shortMonthName 3 = "Mar" -shortMonthName 4 = "Apr" -shortMonthName 5 = "May" -shortMonthName 6 = "Jun" -shortMonthName 7 = "Jul" -shortMonthName 8 = "Aug" -shortMonthName 9 = "Sep" -shortMonthName 10 = "Oct" -shortMonthName 11 = "Nov" -shortMonthName 12 = "Dec" -shortMonthName n = error ("shortMonthName: unknown month number: " ++ show n) - -shortMonthNameP :: Stream s m Char => ParsecT s u m Int +shortMonthName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE shortMonthName #-} +shortMonthName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "Jan" + go 2 = "Feb" + go 3 = "Mar" + go 4 = "Apr" + go 5 = "May" + go 6 = "Jun" + go 7 = "Jul" + go 8 = "Aug" + go 9 = "Sep" + go 10 = "Oct" + go 11 = "Nov" + go 12 = "Dec" + go n = error ("shortMonthName: invalid month: " ⧺ show n) + +shortMonthNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE shortMonthNameP #-} shortMonthNameP = choice [ char 'J' - >> choice [ string "an" >> return 1 + *> choice [ string "an" *> return 1 + , char 'u' + *> choice [ char 'n' *> return 6 + , char 'l' *> return 7 + ] + ] + , string "Feb" *> return 2 + , string "Ma" + *> choice [ char 'r' *> return 3 + , char 'y' *> return 5 + ] + , char 'A' + *> choice [ string "pr" *> return 4 + , string "ug" *> return 8 + ] + , string "Sep" *> return 9 + , string "Oct" *> return 10 + , string "Nov" *> return 11 + , string "Dec" *> return 12 + ] + +longMonthName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE longMonthName #-} +longMonthName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "January" + go 2 = "February" + go 3 = "March" + go 4 = "April" + go 5 = "May" + go 6 = "June" + go 7 = "July" + go 8 = "August" + go 9 = "September" + go 10 = "October" + go 11 = "November" + go 12 = "December" + go n = error ("longMonthName: invalid month: " ⧺ show n) + +longMonthNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE longMonthNameP #-} +longMonthNameP + = choice [ char 'J' + *> choice [ string "anuary" *> return 1 , char 'u' - >> choice [ char 'n' >> return 6 - , char 'l' >> return 7 + *> choice [ string "ne" *> return 6 + , string "ly" *> return 7 ] ] - , string "Feb" >> return 2 + , string "February" *> return 2 , string "Ma" - >> choice [ char 'r' >> return 3 - , char 'y' >> return 5 + *> choice [ string "rch" *> return 3 + , char 'y' *> return 5 ] , char 'A' - >> choice [ string "pr" >> return 4 - , string "ug" >> return 8 + *> choice [ string "pril" *> return 4 + , string "ugust" *> return 8 ] - , string "Sep" >> return 9 - , string "Oct" >> return 10 - , string "Nov" >> return 11 - , string "Dec" >> return 12 + , string "September" *> return 9 + , string "October" *> return 10 + , string "November" *> return 11 + , string "December" *> return 12 ] -show4 :: Integral i => i -> String -show4 i - | i >= 0 && i < 10 = "000" ++ show i - | i >= 0 && i < 100 = "00" ++ show i - | i >= 0 && i < 1000 = "0" ++ show i - | i >= 0 && i < 10000 = show i - | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ++ show i) - -show2 :: Integral i => i -> String -show2 i - | i >= 0 && i < 10 = "0" ++ show i - | i >= 0 && i < 100 = show i - | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ++ show i) - -read4 :: (Stream s m Char, Num n) => ParsecT s u m n -read4 = do n1 <- digit' - n2 <- digit' - n3 <- digit' - n4 <- digit' +show4 ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show4 #-} +show4 = A.unsafeFromBuilder ∘ go + where + {-# INLINEABLE go #-} + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i + | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i + | i ≥ 0 ∧ i < 10000 = BT.integral i + | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i) + +show2 ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show2 #-} +show2 = A.unsafeFromBuilder ∘ go + where + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = BT.integral i + | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i) + +show2' ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show2' #-} +show2' = A.unsafeFromBuilder ∘ go + where + go i | i ≥ 0 ∧ i < 10 = B.fromByteString " " ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = BT.integral i + | otherwise = error ("show2': the integer i must satisfy 0 <= i < 100: " ⧺ show i) + +read4 ∷ Num n ⇒ Parser n +{-# INLINEABLE read4 #-} +read4 = do n1 ← digit' + n2 ← digit' + n3 ← digit' + n4 ← digit' return (n1 * 1000 + n2 * 100 + n3 * 10 + n4) -read2 :: (Stream s m Char, Num n) => ParsecT s u m n -read2 = do n1 <- digit' - n2 <- digit' +read2 ∷ Num n ⇒ Parser n +{-# INLINEABLE read2 #-} +read2 = do n1 ← digit' + n2 ← digit' return (n1 * 10 + n2) -digit' :: (Stream s m Char, Num n) => ParsecT s u m n -digit' = liftM fromC digit +read2' ∷ Num n ⇒ Parser n +{-# INLINEABLE read2' #-} +read2' = do n1 ← (char ' ' *> pure 0) <|> digit' + n2 ← digit' + return (n1 * 10 + n2) + +digit' ∷ Num n ⇒ Parser n +digit' = fromC <$> P.digit -fromC :: Num n => Char -> n +fromC ∷ Num n ⇒ Char → n fromC '0' = 0 fromC '1' = 1 fromC '2' = 2 @@ -149,3 +256,87 @@ fromC '7' = 7 fromC '8' = 8 fromC '9' = 9 fromC _ = undefined + +show4digitsTZ ∷ TimeZone → AsciiBuilder +show4digitsTZ tz + = case timeZoneMinutes tz of + offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset) + | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset + where + showTZ' offset + = let h = offset `div` 60 + m = offset - h * 60 + in + show2 h ⊕ show2 m + +read4digitsTZ ∷ Parser TimeZone +read4digitsTZ + = do sign ← (char '+' *> return 1) + <|> + (char '-' *> return (-1)) + hour ← read2 + minute ← read2 + let tz = TimeZone { + timeZoneMinutes = sign * (hour * 60 + minute) + , timeZoneSummerOnly = False + , timeZoneName = timeZoneOffsetString tz + } + return tz + +assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m () +{-# INLINEABLE assertWeekDayIsGood #-} +assertWeekDayIsGood givenWD gregDay + = let (_, _, correctWD ) = toWeekDate gregDay + (year, month, day) = toGregorian gregDay + in + unless (givenWD ≡ correctWD) + $ fail + $ concat [ "Gregorian day " + , show year + , "-" + , show month + , "-" + , show day + , " is " + , toStr $ longWeekDayName correctWD + , ", not " + , toStr $ longWeekDayName givenWD + ] + where + toStr ∷ AsciiBuilder → String + toStr = A.toString ∘ A.fromAsciiBuilder + +assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day +{-# INLINEABLE assertGregorianDateIsGood #-} +assertGregorianDateIsGood year month day + = case fromGregorianValid year month day of + Nothing + → fail $ concat [ "Invalid gregorian day: " + , show year + , "-" + , show month + , "-" + , show day + ] + Just gregDay + → return gregDay + +assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay +{-# INLINEABLE assertTimeOfDayIsGood #-} +assertTimeOfDayIsGood hour minute second + = case makeTimeOfDayValid hour minute second of + Nothing + → fail $ concat [ "Invalid time of day: " + , show hour + , ":" + , show minute + , ":" + , showFixed True second + ] + Just tod + → return tod + +optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a) +{-# INLINE optionMaybe #-} +optionMaybe p + = option Nothing (Just <$> p)