1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
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
|
