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
|
{-# LANGUAGE RecordWildCards, ApplicativeDo, FlexibleContexts, ViewPatterns, OverloadedStrings #-}
module Main (main) where
import Postdelay.Scan
import Postdelay.Queue
import Data.Function (on)
import Data.List
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
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
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 Lazy.BS.getContents
delay <- scan $ Lazy.Char8.BS.unpack mailStr
let
(headers, body) = break (== "") $ Lazy.Char8.BS.lines mailStr
headers' = filter (not . (Lazy.Char8.BS.isPrefixOf `on` CI.foldCase) "X-Delay:") headers
mailStr' = Lazy.Char8.BS.unlines $ headers' ++ body
sendNow = sendmail sender recipients mailStr'
sendLater sendDelay = pushStore . yield $ StoredMail
{ message = mailStr'
, ..
}
maybe sendNow sendLater delay
|
