From 636bf21caf774a6eef4e678b79bad524c9ef3b01 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 29 Jan 2017 01:21:09 +0100 Subject: Feature complete time specification --- lib/Postdelay/Scan.hs | 37 +++++- lib/Postdelay/TimeSpec.hs | 326 +++++++++++++++++++++++++++++++++++++++++++++- lib/Postdelay/Types.hs | 2 +- 3 files changed, 354 insertions(+), 11 deletions(-) (limited to 'lib') diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs index e6de0cf..fba9f35 100644 --- a/lib/Postdelay/Scan.hs +++ b/lib/Postdelay/Scan.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns #-} module Postdelay.Scan ( scan @@ -12,13 +12,17 @@ import Postdelay.TimeSpec import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Error.Class +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.List +import Control.Exception.Base import Text.Parsec.Char import Text.Parsec.Prim import Text.Parsec.Combinator import Text.Parsec.Error (ParseError(..)) import Text.ParserCombinators.Parsec.Rfc2822 +import Codec.MIME.Decode (decodeWords) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -26,18 +30,39 @@ import qualified Data.CaseInsensitive as CI import Data.Either import Data.Foldable import Data.Semigroup +import Data.Time +import Data.List +import Data.Ord +import Data.Ratio + +import Data.Time.Zones +import System.Time (CalendarTime(..)) + +import Debug.Trace scan :: (MonadIO m, MonadError ParseError m) => String -> m (Maybe Delay) scan = fmap getOption . extractDelay <=< either throwError return . parse message "" extractDelay :: forall m. (MonadIO m, MonadError ParseError m) => Message -> m (Option Delay) -extractDelay (Message headers _) = foldMap pure <$> mapM parseDelay delayHeaders +extractDelay (Message headers _) + = let latestCtx = maximumBy (comparing baseTime) dateHeaders + in foldMap pure <$> mapM (flip runReaderT latestCtx . parseDelay) delayHeaders where delayHeaders :: [Field] delayHeaders = do - h@(OptionalField field content) <- headers + (OptionalField field content) <- headers guard $ CI.mk field == "X-Delay" - return h - parseDelay :: Field -> m Delay + return . OptionalField field $ decodeWords content + dateHeaders :: [TimeCtx] + dateHeaders = do + (Date CalendarTime{..}) <- headers + let tz = minutesToTimeZone . round $ ctTZ % 60 + return $ TimeCtx + { baseTime = localTimeToUTC tz $ LocalTime + (fromGregorian (fromIntegral ctYear) (fromEnum ctMonth + 1) ctDay) + (TimeOfDay ctHour ctMin $ fromIntegral ctSec + fromIntegral ctPicosec * 1e-12) + , tz = Left tz + } + parseDelay :: Field -> ReaderT TimeCtx m Delay parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs index b080dcc..af8d801 100644 --- a/lib/Postdelay/TimeSpec.hs +++ b/lib/Postdelay/TimeSpec.hs @@ -1,14 +1,332 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns, ConstraintKinds, TupleSections, RecordWildCards #-} + module Postdelay.TimeSpec ( pTimeSpec + , TimeCtx(..) ) where +import Control.Monad import Control.Monad.IO.Class -import Data.Time +import Control.Monad.Reader.Class +import Control.Monad.Error.Class -import Text.Parsec.Char +import Text.Parsec.Char hiding (digit) +import qualified Text.Parsec.Char as Parsec (digit) import Text.Parsec.Prim import Text.Parsec.Combinator import Text.Parsec.Error (ParseError(..)) +import Text.Read (readMaybe) + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.Zones +import Data.Function +import Data.Maybe +import Data.Foldable +import Data.Ord +import Data.List +import Data.Tuple +import Data.Bool + +import Control.Exception (IOException) + +import Debug.Trace + + +type MonadTP m = (MonadIO m, MonadReader TimeCtx m) + +data TimeCtx = TimeCtx + { baseTime :: UTCTime + , tz :: Either TimeZone TZ + } + + +spaced :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a +spaced p = spaces *> p <* spaces + +string' :: Stream s m Char => String -> ParsecT s u m String +string' = mapM $ satisfy . ((==) `on` CI.mk) + +choice' :: (Stream s m t, Foldable f) => f (ParsecT s u m a) -> ParsecT s u m a +choice' (toList -> f) + | [p] <- f = p + | (p:ps) <- f = try p <|> choice' ps + | otherwise = mzero + +strChoice' :: Stream s m Char => [String] -> ParsecT s u m String +strChoice' = choice' . map string' . sortBy (comparing $ Down . length) + +natural :: (Stream s m Char, Num a) => ParsecT s u m a +natural = foldl' (\init last -> init * 10 + last) 0 <$> many1 digit + +decimal :: (Stream s m Char, Num a, Fractional a) => ParsecT s u m a +decimal = do + w <- foldl' (\init last -> init * 10 + last) 0 <$> many1 digit + f <- option 0 $ do + char '.' + foldr' (\head tail -> head + tail / 10) 0 <$> many1 digit + return $ w + f / 10 + +digit :: (Stream s m Char, Num a) => ParsecT s u m a +digit = fromIntegral . (\c -> fromEnum c - fromEnum '0') <$> Parsec.digit + +ensure :: MonadPlus m => (a -> Bool) -> a -> m a +ensure p x = bool (const mzero) return (p x) $ x + + +pTimeSpec :: MonadTP m => ParsecT String () m UTCTime +pTimeSpec = choice' [ flip addUTCTime <$> spaced pSpecBase <*> spaced pSpecOffset "Absolute time + offset" + , flip addUTCTime <$> asks baseTime <*> spaced pSpecOffset "Time offset" + , spaced pSpecBase "Absolute time" + ] + <* eof "Time specification" + +pSpecBase :: forall m. MonadTP m => ParsecT String () m UTCTime +pSpecBase = choice' + [ utcTime <$> spaced pDate <*> spaced pTime + , flip utcTime <$> spaced pTime <*> spaced pDate + , do + proto@(UTCTime{..}) <- utcTime <$> (utctDay <$> asks baseTime) <*> spaced pTime + now <- asks baseTime + return $ if proto < now + then UTCTime (succ utctDay) utctDayTime + else proto + , utcTime <$> spaced pDate <*> ((dayFractionToTimeOfDay 0, ) <$> asks tz) + , spaced (string' "now") *> asks baseTime + ] "Base specification" + where + utcTime :: Day -> (TimeOfDay, Either TimeZone TZ) -> UTCTime + utcTime d (t, Right tz) = localTimeToUTCTZ tz (LocalTime d t) + utcTime d (t, Left tz) = localTimeToUTC tz (LocalTime d t) + +pSpecOffset :: MonadTP m => ParsecT String () m NominalDiffTime +pSpecOffset = (+) <$> pSpecOffset' <*> option 0 (try (many $ space <|> char ',' <|> char ';') >> pSpecOffset) + where + pSpecOffset' = option id (spaced pSign) <*> ((*) <$> spaced pNumber <*> spaced pSpecOffsetConst) "Time offset" + pNumber = fromInteger <$> natural "Offset multiplier" + +pSign :: MonadTP m => ParsecT String () m (NominalDiffTime -> NominalDiffTime) +pSign = choice [ id <$ char '+' + , negate <$ char '-' + ] "Offset sign" + +pSpecOffsetConst :: MonadTP m => ParsecT String () m NominalDiffTime +pSpecOffsetConst = choice' [ 1e-12 <$ strChoice' [ "ps" + , "picosecond" + , "picoseconds" + ] + , 1e-9 <$ strChoice' [ "ns" + , "nanosecond" + , "nanoseconds" + ] + , 1e-6 <$ strChoice' [ "us", "µs" + , "microsecond" + , "microseconds" + ] + , 1e-3 <$ strChoice' [ "ms" + , "millisecond" + , "milliseconds" + ] + , 1e-2 <$ strChoice' [ "ds" + , "decisecond" + , "deciseconds" + ] + , 1e-1 <$ strChoice' [ "cs" + , "centisecond" + , "centiseconds" + ] + , 1 <$ strChoice' [ "s" + , "second" + , "seconds" + ] + , 60 <$ strChoice' [ "min" + , "minute" + , "minutes" + ] + , 3600 <$ strChoice' [ "h" + , "hour" + , "hours" + ] + , 24 * 3600 <$ strChoice' [ "d" + , "day" + , "days" + ] + , 7 * 24 * 3600 <$ strChoice' [ "week" + , "weeks" + ] + , 30 * 24 * 3600 <$ strChoice' [ "month" + , "months" + ] + , 365 * 24 * 3600 <$ strChoice' [ "year" + , "years" + ] + ] "Offset unit" + +pDate :: MonadTP m => ParsecT String () m Day +pDate = choice' [ do + (m, d) <- choice' [ do + m <- spaced pMonthName + d <- spaced natural + optional . spaced $ char ',' + return (m, d) + , fmap swap . (,) <$> spaced natural <*> spaced pMonthName + ] + y <- spaced natural + fromGregorian' y m d + , do + now <- asks baseTime + (m, d) <- choice' [ (,) <$> spaced pMonthName <*> spaced natural + , fmap swap . (,) <$> spaced natural <*> spaced pMonthName + ] + let + (y, _, _) = toGregorian $ utctDay now + proto <- fromGregorian' y m d + if proto < utctDay now + then fromGregorian' (y + 1) m d + else return proto + , do + now <- asks baseTime + optional $ spaces *> pNext <* many1 space + d <- spaced pWeekdayName + let + (y, w, _) = toWeekDate $ utctDay now + proto <- fromWeekDate' y w d + if proto < utctDay now + then maybe (fromWeekDate' (y + 1) 1 d) return $ fromWeekDateValid y (w + 1) d + else return proto + , do + spaced $ string' "today" + utctDay <$> asks baseTime + , do + spaced $ string' "tomorrow" + succ . utctDay <$> asks baseTime + , do + y <- natural + char '-' + m <- natural + char '-' + d <- natural + fromGregorian' y m d + , do + d <- natural + char '.' + m <- natural + char '.' + y <- natural + fromGregorian' y m d + , do + m <- natural + char '/' + d <- natural + char '/' + y <- natural + fromGregorian' y m d + , do + ds <- many1 digit + when (length ds < 5) $ fail "Insufficient digits to interpret as concatenated date" + let + d2 : d1 : m2 : m1 : ys = reverse ds + d = 10 * d1 + d2 + m = 10 * m1 + m2 + y = foldl' (\init last -> init * 10 + last) 0 . map fromIntegral $ reverse ys + fromGregorian' y m d + , do + pNext + many1 space + fmap utctDay . addUTCTime <$> pSpecOffsetConst <*> asks baseTime + ] "Day specification" + where + fromGregorian' y m d = maybe (fail "Invalid gregorian date") return $ fromGregorianValid y m d + fromWeekDate' y w d = maybe (fail "Invalid iso8601 date") return $ fromWeekDateValid y w d + pNext = string' "next" + +pMonthName :: MonadTP m => ParsecT String () m Int +pMonthName = choice' (zipWith (<$) [1..] [ strChoice' [ "January", "Jan" ] + , strChoice' [ "Febuary", "Feb" ] + , strChoice' [ "March", "Mar" ] + , strChoice' [ "April", "Apr" ] + , strChoice' [ "May" ] + , strChoice' [ "June", "Jun" ] + , strChoice' [ "July", "Jul" ] + , strChoice' [ "August", "Aug" ] + , strChoice' [ "September", "Sep" ] + , strChoice' [ "October", "Oct" ] + , strChoice' [ "November", "Nov" ] + , strChoice' [ "December", "Dec" ] + ]) "Month name" + +pWeekdayName :: MonadTP m => ParsecT String () m Int +pWeekdayName = choice' (zipWith (<$) [1..] [ strChoice' [ "Monday", "Mon" ] + , strChoice' [ "Tuesday", "Tue" ] + , strChoice' [ "Wednesday", "Wed" ] + , strChoice' [ "Thursday", "Thu" ] + , strChoice' [ "Friday", "Fri" ] + , strChoice' [ "Saturday", "Sat" ] + , strChoice' [ "Sunday", "Sun" ] + ]) + +pTime :: MonadTP m => ParsecT String () m (TimeOfDay, Either TimeZone TZ) +pTime = choice' [ (,) <$> spaced pTimeBase <*> spaced pTimeZone + , (,) <$> spaced pTimeBase <*> asks tz + ] "Time of day and timezone specification" + +data AMPM = AM | PM + deriving (Eq, Ord, Enum) + +pTimeBase :: MonadTP m => ParsecT String () m TimeOfDay +pTimeBase = choice' [ do + h <- pHour12 + m <- option 0 $ char ':' >> pMinute + s <- option 0 $ char ':' >> pSecond + amPM <- spaced pAMPM + let h' = h + fromEnum amPM * 12 + return $ TimeOfDay h' m s + , do + h <- pHour + m <- option 0 $ char ':' >> pMinute + s <- option 0 $ char ':' >> pSecond + return $ TimeOfDay h m s + , do + h <- ensure (<= 24) =<< (\d u -> 10 * d + u) <$> digit <*> digit + m <- option 0 $ ensure (< 60) =<< (\d u -> 10 * d + u) <$> digit <*> digit + s <- option 0 $ pSecond + return $ TimeOfDay h m s + , TimeOfDay 0 0 0 <$ string' "midnight" + , TimeOfDay 12 0 0 <$ string' "noon" + , TimeOfDay 16 0 0 <$ string' "teatime" + ] "Time of day specification" + where + pAMPM = choice [ AM <$ string' "AM" + , PM <$ string' "PM" + ] + pHour12 = (`rem` 12) <$> (ensure (<= 12) =<< natural) + + pHour = (`rem` 24) <$> (ensure (<= 24) =<< natural) + pMinute = ensure (< 60) =<< natural + pSecond = decimal -pTimeSpec :: MonadIO m => ParsecT String () m UTCTime -pTimeSpec = undefined +pTimeZone :: MonadTP m => ParsecT String () m (Either TimeZone TZ) +pTimeZone = choice' [ do + sgn <- choice [ id <$ char '+' + , negate <$ char '-' + ] + hs <- (\d u -> 10 * d + u) <$> digit <*> digit + ms <- option 0 $ (\d u -> 10 * d + u) <$> digit <*> digit + return . Left . minutesToTimeZone $ hs * 60 + ms + , do + n <- many1 $ letter <|> char '/' + tz <- liftIO $ do + let + fbHandler :: IO a -> (IOException -> IO a) + fbHandler fb _ = fb + foldl (\fb a -> a `catchError` fbHandler fb) (return Nothing) + [ Just <$> loadSystemTZ n + , Just <$> loadTZFromDB n + ] + case tz of + Nothing -> fail $ "Could not resolve timezone: " ++ n + (Just tz) -> return $ Right tz + ] diff --git a/lib/Postdelay/Types.hs b/lib/Postdelay/Types.hs index 3f66fb8..d5f8325 100644 --- a/lib/Postdelay/Types.hs +++ b/lib/Postdelay/Types.hs @@ -7,7 +7,7 @@ import Data.Semigroup import Data.Time.Clock (UTCTime) newtype Delay = Until { releaseTime :: UTCTime } - deriving (Eq, Ord) + deriving (Eq, Ord, Show) instance Semigroup Delay where (Until a) <> (Until b) = Until $ max a b -- cgit v1.2.3