Framework for spooling

6 files changed, 195 insertions, 29 deletions

diff --git a/lib/Postdelay/Queue.hs b/lib/Postdelay/Queue.hs
new file mode 100644
index 0000000..ac760ec
--- /dev/null
+++ b/lib/Postdelay/Queue.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE RankNTypes, RecordWildCards, ApplicativeDo, FlexibleContexts #-}
+
+module Postdelay.Queue
+  ( sendmail
+  , StoredMailF(..)
+  , StoredMail, StoredMail'
+  , sendStored, sendStored'
+  , StoreConfig, storeConfig
+  , pushStore, popStore
+  ) where
+
+import Postdelay.Types
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Catch (handle, MonadThrow(throwM))
+import Control.Monad.Trans.Maybe
+import Control.Monad.Reader
+import Control.Monad.Trans.Class
+import Control.Monad
+
+import System.IO (hClose, stderr)
+import System.IO.Error
+import GHC.IO.Exception
+import System.Process
+
+import Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy as Lazy.BS
+
+import Foreign.C.Error (Errno(..), ePIPE)
+
+import Data.Bool
+import Data.Conduit
+import Data.Time
+
+import qualified Options.Applicative as Opt (Parser)
+import Options.Applicative hiding (Parser)
+
+
+data StoredMailF a = StoredMail
+  { sendDelay :: Delay
+  , sender :: String
+  , recipients :: [String]
+  , message :: a
+  }
+
+type StoredMail = StoredMailF Lazy.ByteString
+type StoredMail' = StoredMailF (IO Lazy.ByteString)
+
+data StoreConfig = StoreConfig
+  { storeLocation :: FilePath
+  }
+
+
+storeConfig :: Opt.Parser StoreConfig
+storeConfig = do
+  storeLocation <- strOption $ mconcat
+    [ long "spool"
+    , short 's'
+    , metavar "PATH"
+    , help "Where to expect the mail spool"
+    ]
+  pure StoreConfig{..}
+
+
+sendmail' :: MonadIO m
+         => [String] -- ^ Arguments to sendmail
+         -> Lazy.ByteString -- ^ Message
+         -> m ()
+sendmail' args mail = liftIO . withCreateProcess cp $ \(Just inh) _ _ pHandle -> do
+  ignoreSigPipe $ do
+    Lazy.BS.hPutStr inh mail
+    hClose inh
+
+  ret <- waitForProcess pHandle
+  bool throwM (\_ -> return ()) (ret == ExitSuccess) $ ret
+  where
+    cp = (proc "sendmail" args)
+      { std_in = CreatePipe
+      }
+    ignoreSigPipe = handle $ \e -> case e of
+      IOError { ioe_type  = ResourceVanished
+              , ioe_errno = Just ioe }
+        | Errno ioe == ePIPE -> return ()
+      _ -> throwM e
+
+sendmail :: MonadIO m
+         => String -- ^ Sender
+         -> [String] -- ^ Recipients
+         -> Lazy.ByteString -- ^ Message
+         -> m ()
+sendmail sender recipients = sendmail' $ ["-G", "-i", "-f", sender, "--"] ++ recipients
+
+sendStored :: MonadIO m => StoredMail -> m ()
+sendStored StoredMail{ sendDelay = Until{..}, ..} = void . runMaybeT $ do
+  now <- liftIO getCurrentTime
+  guard $ now >= releaseTime
+  lift $ sendmail sender recipients message
+
+sendStored' :: MonadIO m => StoredMail' -> m ()
+sendStored' StoredMail{..} = do
+  message' <- liftIO message
+  sendStored StoredMail{ message = message', .. }
+  
+popStore :: (MonadIO m, MonadReader StoreConfig m) => Source m StoredMail'
+popStore = undefined
+
+pushStore :: (MonadIO m, MonadReader StoreConfig m) => Source m StoredMail -> m ()
+pushStore = undefined
diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs
index 7f80818..6355928 100644
--- a/lib/Postdelay/Scan.hs
+++ b/lib/Postdelay/Scan.hs
@@ -3,7 +3,6 @@
 module Postdelay.Scan
   ( scan
   , Delay(..)
-  , ParseError(..)
   ) where
 
 import Postdelay.Types
diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index 951b1c0..f61d84e 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -124,7 +124,7 @@ dateSpec = label "Date" $ (>> scribe (prio' Default . time) midnight) <$> choice
                      scribe (prio' Assign . date.days) 1
                  ]
            , try $ do
-               let daySuffix = optional $ choice [ string' "st", string' "nd", string' "rd", string' "th" ]
+               let daySuffix = optional $ choice [ string ".", string' "st", string' "nd", string' "rd", string' "th" ]
                (m, d) <- choice [ try $ (,) <$> monthName <* spaces <*> dayNumber False <* daySuffix
                                 , try $ flip (,) <$> dayNumber False <* daySuffix <* spaces <*> monthName
                                 ]
diff --git a/postdelay.cabal b/postdelay.cabal
index ad8f59e..8be804b 100644
--- a/postdelay.cabal
+++ b/postdelay.cabal
@@ -19,9 +19,11 @@ cabal-version:       >=1.10
 library
   exposed-modules:     Postdelay.Scan
                      , Postdelay.Types
+                     , Postdelay.Queue
   other-modules:       Postdelay.TimeSpec
                      , Postdelay.TimeSpec.Units
                      , Postdelay.TimeSpec.Utils
+                     , Postdelay.PrioMap
   build-depends:       base >=4.9 && <5
                      , time >=1.6 && <2
                      , parsec >=3.1 && <4
@@ -40,6 +42,12 @@ library
                      , lens-datetime >=0.3 && <1
                      , data-interval >=1.2 && <2
                      , containers >=0.5.7 && <1
+                     , vector-space >=0.10 && <1
+                     , process >=1.4 && <2
+                     , conduit >=1.2 && <2
+                     , transformers >=0.5 && <1
+                     , bytestring >=0.10 && <1
+                     , optparse-applicative >=0.13 && <1
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
@@ -49,6 +57,11 @@ executable postdelay-simple
   -- other-extensions:    
   build-depends:       base >=4.9 && <5
                      , postdelay
-                     , transformers >=0.5 && <1
+                     , case-insensitive >=1.2 && <2
+                     , exceptions >=0.8 && <1
+                     , bytestring >=0.10 && <1
+                     , conduit >=1.2 && <2
+                     , optparse-applicative >=0.13 && <1
+                     , mtl >=2.2 && <3
   hs-source-dirs:      src
   default-language:    Haskell2010
diff --git a/postdelay.nix b/postdelay.nix
index d6fce32..647b2ae 100644
--- a/postdelay.nix
+++ b/postdelay.nix
@@ -1,7 +1,8 @@
-{ mkDerivation, base, case-insensitive, containers, data-interval
-, exceptions, hsemail, lens, lens-datetime, list-t, megaparsec
-, mime, mtl, old-time, parsec, stdenv, time, transformers, tz
-, units, units-defs
+{ mkDerivation, base, bytestring, case-insensitive, conduit
+, containers, data-interval, exceptions, hsemail, lens
+, lens-datetime, list-t, megaparsec, mime, mtl, old-time
+, optparse-applicative, parsec, process, stdenv, time, transformers
+, tz, units, units-defs, vector-space
 }:
 mkDerivation {
   pname = "postdelay";
@@ -10,11 +11,15 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base case-insensitive containers data-interval exceptions hsemail
-    lens lens-datetime list-t megaparsec mime mtl old-time parsec time
-    tz units units-defs
+    base bytestring case-insensitive conduit containers data-interval
+    exceptions hsemail lens lens-datetime list-t megaparsec mime mtl
+    old-time optparse-applicative parsec process time transformers tz
+    units units-defs vector-space
+  ];
+  executableHaskellDepends = [
+    base bytestring case-insensitive conduit exceptions mtl
+    optparse-applicative
   ];
-  executableHaskellDepends = [ base transformers ];
   homepage = "https://git.yggdrasil.li/gkleen/pub/postdelay";
   description = "A postfix content filter for delaying delivery of mail";
   license = stdenv.lib.licenses.mit;
diff --git a/src/Simple.hs b/src/Simple.hs
index f461766..68524a8 100644
--- a/src/Simple.hs
+++ b/src/Simple.hs
@@ -1,24 +1,65 @@
+{-# LANGUAGE RecordWildCards, ApplicativeDo, FlexibleContexts #-}
+
 module Main (main) where
 
 import Postdelay.Scan
+import Postdelay.Queue
 
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Except
+import Data.Function (on)
+import Data.List
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
 
-  
-main :: MonadIO m => m ()
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Catch (MonadCatch)
+import Control.Monad.Reader
+
+import Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy as Lazy.BS
+
+import Data.ByteString.Lazy.Char8 as Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8.BS
+
+import Data.Conduit
+
+import System.Environment (getProgName)
+
+import qualified Options.Applicative as Opt (Parser)
+import Options.Applicative hiding (Parser)
+
+
+opts :: Opt.Parser (String, [String], StoreConfig)
+opts = do
+  sConfig <- storeConfig
+  sender <- strOption $ mconcat
+    [ long "sender"
+    , short 'f'
+    , metavar "SENDER"
+    ]
+  recipients <- some . strArgument $ mconcat
+    [ metavar "RECIPIENTS"
+    ]
+  pure (sender, recipients, sConfig)
+
+main :: (MonadIO m, MonadCatch m) => m ()
 main = do
-  mailStr <- liftIO getContents
-  delay <- runExceptT $ scan mailStr
-  case delay of
-    Left err       -> do
-      liftIO . putStrLn $ show err
-      sendNow mailStr
-    Right Nothing  -> sendNow mailStr
-    Right (Just d) -> sendLater mailStr d
-
-sendNow :: MonadIO m => String -> m ()
-sendNow = undefined
-
-sendLater :: MonadIO m => String -> Delay -> m ()
-sendLater = undefined
+  pName <- liftIO getProgName
+  (sender, recipients, sConfig) <- liftIO . execParser . info (helper <*> opts) $ mconcat
+    [ fullDesc
+    , progDesc "Queue an email for later delivery"
+    , header pName
+    ]
+  
+  flip runReaderT sConfig $ do
+    mailStr <- liftIO getContents
+    delay <- scan mailStr
+    let
+      (headers, body) = break (== "") $ lines mailStr
+      mailStr' = unlines $ filter (not . (isPrefixOf `on` CI.foldCase) "X-Delay:") headers ++ body
+
+      sendNow = sendmail sender recipients $ Lazy.Char8.BS.pack mailStr'
+      sendLater sendDelay = pushStore . yield $ StoredMail
+        { message = Lazy.Char8.BS.pack mailStr'
+        , ..
+        }
+    maybe sendNow sendLater delay