From b78644e2fe649207d81a89d0af36988aed110104 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 8 Mar 2017 14:39:38 +0100 Subject: Framework for spooling --- lib/Postdelay/Queue.hs | 108 ++++++++++++++++++++++++++++++++++++++++++++++ lib/Postdelay/Scan.hs | 1 - lib/Postdelay/TimeSpec.hs | 2 +- postdelay.cabal | 15 ++++++- postdelay.nix | 21 +++++---- src/Simple.hs | 77 +++++++++++++++++++++++++-------- 6 files changed, 195 insertions(+), 29 deletions(-) create mode 100644 lib/Postdelay/Queue.hs 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 -- cgit v1.2.3