Feature complete time specification

1 files changed, 31 insertions, 6 deletions

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