Feature complete time specification

9 files changed, 385 insertions, 30 deletions

diff --git a/default.nix b/default.nix
deleted file mode 100644
index 0ba6150..0000000
--- a/default.nix
+++ /dev/null
@@ -1,6 +0,0 @@
-argumentPackages@{ ... }:
-
-let
-  defaultPackages = with (import <nixpkgs> {}); haskellPackages;
-  pkgs = defaultPackages // argumentPackages;
-in pkgs.callPackage ./postdelay.nix {}
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
diff --git a/postdelay.cabal b/postdelay.cabal
index 957e6d5..6b02951 100644
--- a/postdelay.cabal
+++ b/postdelay.cabal
@@ -26,7 +26,11 @@ library
                      , parsec >=3.1 && <4
                      , case-insensitive >=1.2 && <2
                      , hsemail >=1.7 && <2
+                     , mime >=0.4 && <1
                      , mtl >=2.2 && <3
+                     , tz >=0.1 && <1
+                     , old-time >=1.1 && <2
+                     , list-t >=1 && <2
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
diff --git a/postdelay.nix b/postdelay.nix
index 66dae61..701af04 100644
--- a/postdelay.nix
+++ b/postdelay.nix
@@ -1,5 +1,5 @@
-{ mkDerivation, base, case-insensitive, hsemail, mtl, parsec
-, stdenv, time, transformers
+{ mkDerivation, base, case-insensitive, hsemail, list-t, mime, mtl
+, old-time, parsec, stdenv, time, transformers, tz
 }:
 mkDerivation {
   pname = "postdelay";
@@ -8,7 +8,8 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base case-insensitive hsemail mtl parsec time
+    base case-insensitive hsemail list-t mime mtl old-time parsec time
+    tz
   ];
   executableHaskellDepends = [ base transformers ];
   homepage = "https://git.yggdrasil.li/gkleen/pub/postdelay";
diff --git a/postdelay.nix.gup b/postdelay.nix.gup
index 976221f..bc92dcd 100644
--- a/postdelay.nix.gup
+++ b/postdelay.nix.gup
@@ -2,4 +2,4 @@
 
 gup -u ${2:r}.cabal
 cd ${2:h}
-cabal2nix ./. >! ${1}
\ No newline at end of file
+cabal2nix ./. >! ${1}
diff --git a/result.gup b/result.gup
index 5c03e49..f1c92fa 100644
--- a/result.gup
+++ b/result.gup
@@ -1,4 +1,8 @@
 #!/usr/bin/env zsh
 
+gup --always
 gup -u postdelay.nix default.nix
-nix-build -o ${1} ./default.nix
\ No newline at end of file
+
+nix-build -o ${1} ./default.nix
+
+find . \( \( -name '.gup' -or -name '.git' \) -prune \) -or \( -type f -exec shasum '{}' ';' \) | gup --contents
\ No newline at end of file
diff --git a/shell.nix b/shell.nix
index a4274e7..27b7d06 100644
--- a/shell.nix
+++ b/shell.nix
@@ -1,9 +1,18 @@
-{ pkgs ? (import <nixpkgs> {})
-}:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
 
-pkgs.lib.overrideDerivation (pkgs.haskellPackages.callPackage ./default.nix {}) (oldArgs: {
-  buildInputs = with pkgs; [ cabal2nix gup ];
-  shellHook = ''
-    export PROMPT_INFO=${oldArgs.name}
-  '';
-})
+let
+  inherit (nixpkgs) pkgs;
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  drv = haskellPackages.callPackage ./postdelay.nix {};
+in
+  pkgs.stdenv.lib.overrideDerivation drv.env (oldAttrs: {
+    buildInputs = oldAttrs.buildInputs ++ (with pkgs; [ cabal2nix gup ]);
+    shellHook = ''
+      ${oldAttrs.shellHook}
+      export PROMPT_INFO="${oldAttrs.name}"
+    '';
+  })