Establish framework

1 files changed, 22 insertions, 17 deletions

diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs
index 2f0a78a..888a237 100644
--- a/lib/Postdelay/Scan.hs
+++ b/lib/Postdelay/Scan.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns, TupleSections #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns, TupleSections, RankNTypes #-}
 
 module Postdelay.Scan
   ( scan
@@ -7,20 +7,18 @@ module Postdelay.Scan
   ) where
 
 import Postdelay.Types
-import Postdelay.Utils
 import Postdelay.TimeSpec
 
 import Control.Monad
 import Control.Monad.IO.Class
-import Control.Monad.Except
+import Control.Monad.Catch
 import Control.Monad.Reader
 import Control.Monad.List
 import Control.Exception.Base
+import Control.Lens
 
-import Text.Parsec.Char
-import Text.Parsec.Prim
-import Text.Parsec.Combinator
-import Text.Parsec.Error (ParseError(..))
+import qualified Text.Parsec as P
+import Text.Megaparsec
 import Text.ParserCombinators.Parsec.Rfc2822
 import Codec.MIME.Decode (decodeWords)
 
@@ -40,17 +38,20 @@ import System.Time (CalendarTime(..))
 
 import Debug.Trace
 
+instance Exception P.ParseError
 
-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)
+scan :: (MonadIO m, MonadThrow m) => String -> m (Maybe Delay)
+scan = fmap getOption . extractDelay <=< either throwM return . P.parse message ""
+
+extractDelay :: forall m. (MonadIO m, MonadThrow m) => Message -> m (Option Delay)
 extractDelay (Message headers _) = do
-  zones <- zoneHeaders
-  let (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders
-      tz = foldr' (flip (<>)) (Left dateTz) zones
-  foldMap pure <$> mapM (flip runReaderT TimeCtx{..} . parseDelay) delayHeaders
+  tz <- foldr' (flip (<>)) (Left dateTz) <$> zoneHeaders
+  let apply f = Until (baseTime & localT tz %~ appEndo f)
+  fmap apply . foldMap pure <$> mapM parseDelay delayHeaders
   where
+    (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders
+
     delayHeaders :: [Field]
     delayHeaders = do
       (OptionalField field content) <- headers
@@ -67,7 +68,11 @@ extractDelay (Message headers _) = do
     zoneHeaders = runListT $ do
       (OptionalField field content) <- ListT $ return headers
       guard $ CI.mk field == "X-Timezone"
-      Right r <- runParserT (spaces *> pTimeZone <* spaces <* eof) () field content
+      Right r <- runParserT (spaceConsumer *> lexeme pTimeZone <* eof) field content
       return r
-    parseDelay :: Field -> ReaderT TimeCtx m Delay
-    parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content
+    parseDelay :: Field -> m (Endo LocalTime)
+    parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> lexeme pTimeSpec <* eof) field content
+
+localT :: Either TimeZone TZ -> Iso' UTCTime LocalTime
+localT (Left tz) = iso (utcToLocalTime tz) (localTimeToUTC tz)
+localT (Right tz) = iso (utcToLocalTimeTZ tz) (localTimeToUTCTZ tz)