Framework for spooling

3 files changed, 109 insertions, 2 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
                                 ]