Basic concepts

4 files changed, 91 insertions, 0 deletions

diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs
new file mode 100644
index 0000000..e6de0cf
--- /dev/null
+++ b/lib/Postdelay/Scan.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts #-}
+
+module Postdelay.Scan
+  ( scan
+  , Delay(..)
+  , ParseError(..)
+  ) where
+
+import Postdelay.Types
+import Postdelay.Utils
+import Postdelay.TimeSpec
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Error.Class
+
+import Text.Parsec.Char
+import Text.Parsec.Prim
+import Text.Parsec.Combinator
+import Text.Parsec.Error (ParseError(..))
+import Text.ParserCombinators.Parsec.Rfc2822
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Either
+import Data.Foldable
+import Data.Semigroup
+
+
+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
+  where
+    delayHeaders :: [Field]
+    delayHeaders = do
+      h@(OptionalField field content) <- headers
+      guard $ CI.mk field == "X-Delay"
+      return h
+    parseDelay :: Field -> 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
new file mode 100644
index 0000000..b080dcc
--- /dev/null
+++ b/lib/Postdelay/TimeSpec.hs
@@ -0,0 +1,14 @@
+module Postdelay.TimeSpec
+  ( pTimeSpec
+  ) where
+
+import Control.Monad.IO.Class
+import Data.Time
+
+import Text.Parsec.Char
+import Text.Parsec.Prim
+import Text.Parsec.Combinator
+import Text.Parsec.Error (ParseError(..))
+
+pTimeSpec :: MonadIO m => ParsecT String () m UTCTime
+pTimeSpec = undefined
diff --git a/lib/Postdelay/Types.hs b/lib/Postdelay/Types.hs
new file mode 100644
index 0000000..3f66fb8
--- /dev/null
+++ b/lib/Postdelay/Types.hs
@@ -0,0 +1,13 @@
+module Postdelay.Types
+  ( Delay(..)
+  ) where
+
+import Data.Semigroup
+
+import Data.Time.Clock (UTCTime)
+
+newtype Delay = Until { releaseTime :: UTCTime }
+  deriving (Eq, Ord)
+
+instance Semigroup Delay where
+  (Until a) <> (Until b) = Until $ max a b
diff --git a/lib/Postdelay/Utils.hs b/lib/Postdelay/Utils.hs
new file mode 100644
index 0000000..d716b4d
--- /dev/null
+++ b/lib/Postdelay/Utils.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Postdelay.Utils
+  ( hoistParsecT
+  ) where
+
+import Control.Monad.Error.Class
+
+import Data.Functor
+import Data.Either
+
+import Data.Functor.Identity
+import Text.Parsec.Prim
+import Text.Parsec.Error
+
+hoistParsecT :: (Monad m, Stream s Identity t, Stream s m t) => ParsecT s u Identity a -> ParsecT s u m a
+hoistParsecT p = do
+  st <- getParserState
+  let res = runParser p' undefined "" undefined
+      p' = setParserState st >> ((,) <$> getState <*> p)
+  either (fail . show) (\(st', res) -> putState st' $> res) $ res