Lisää mahdollisuus katsoa lähetettäviä viestejä ennen lähettämistä

This commit is contained in:
Saku Laesvuori 2023-11-24 16:26:55 +02:00
parent f11ddb8ca4
commit c2cda17113
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
3 changed files with 28 additions and 16 deletions

View File

@ -33,13 +33,23 @@ main = do
UpdateTable bankCsv -> updateTableMain csv bankCsv UpdateTable bankCsv -> updateTableMain csv bankCsv
sendInvoicesMain :: FilePath -> SendOptions -> IO () sendInvoicesMain :: FilePath -> SendOptions -> IO ()
sendInvoicesMain csvPath options@SendOptions {email, sendmail, reminders} = do sendInvoicesMain csvPath options@SendOptions {email, sendmail, reminders, dryRun} = do
invoices <- mapMaybe (\(address, invoice) -> (address,) <$> renderEmail reminders [email] address invoice) <$> readInvoices csvPath options invoices <- readInvoices csvPath options
forM_ invoices $ \(address, invoiceMail) -> do forM_ invoices $ \(address, invoice) -> do
sendEmail sendmail invoiceMail case renderInvoice reminders invoice of
Nothing -> pure ()
Just (subject, body) -> do
case dryRun of
False -> do
sendEmail sendmail $ renderEmail [email] address subject body
putStr "Lähetetty osoitteeseen: " putStr "Lähetetty osoitteeseen: "
T.putStrLn $ decodeUtf8 $ renderAddresses address T.putStrLn $ decodeUtf8 $ renderAddresses address
threadDelay (3 * 1000 * 1000) threadDelay (3 * 1000 * 1000)
True -> do
T.putStrLn $ "To: " <> decodeUtf8 (renderAddresses address)
T.putStrLn $ "From: " <> decodeUtf8 (renderAddresses [email])
T.putStrLn $ "\n" <> body
T.putStrLn "-------\n"
updateTableMain :: FilePath -> FilePath -> IO () updateTableMain :: FilePath -> FilePath -> IO ()
updateTableMain invoiceCsv transactionCsv = do updateTableMain invoiceCsv transactionCsv = do

View File

@ -3,7 +3,7 @@
module Laskutin.Email where module Laskutin.Email where
import Data.Text (Text) import Data.Text (Text)
import Data.MIME (MIMEMessage, Address, createTextPlainMessage, defaultCharsets, headerSubject, headerFrom, headerTo, headerBCC, renderMessage) import Data.MIME (Address, createTextPlainMessage, defaultCharsets, headerSubject, headerFrom, headerTo, headerBCC, renderMessage)
import Control.Lens (set) import Control.Lens (set)
import Data.Semigroup (sconcat) import Data.Semigroup (sconcat)
import Data.Time.Calendar import Data.Time.Calendar
@ -19,12 +19,13 @@ import qualified Data.ByteString.Lazy as LBS
import Laskutin.Types import Laskutin.Types
renderEmail :: Bool -> [Address] -> [Address] -> Invoice -> Maybe ByteString renderEmail :: [Address] -> [Address] -> Text -> Text -> ByteString
renderEmail isReminder senders recipients = fmap (renderMessage renderEmail senders recipients subject = renderMessage
. set (headerBCC defaultCharsets) senders . set (headerBCC defaultCharsets) senders
. set (headerTo defaultCharsets) recipients . set (headerTo defaultCharsets) recipients
. set (headerFrom defaultCharsets) senders) . set (headerFrom defaultCharsets) senders
. invoiceEmail isReminder . set (headerSubject defaultCharsets) (Just subject)
. createTextPlainMessage
sendEmail :: FilePath -> ByteString -> IO () sendEmail :: FilePath -> ByteString -> IO ()
sendEmail sendmail email = do sendEmail sendmail email = do
@ -36,10 +37,9 @@ sendEmail sendmail email = do
ExitSuccess -> pure () ExitSuccess -> pure ()
ExitFailure code -> throwIO $ ErrorCall ("sendmail exited with error code " <> show code) ExitFailure code -> throwIO $ ErrorCall ("sendmail exited with error code " <> show code)
invoiceEmail :: Bool -> Invoice -> Maybe MIMEMessage renderInvoice :: Bool -> Invoice -> Maybe (Text, Text)
invoiceEmail _ Invoice {isPaid = True} = Nothing renderInvoice _ Invoice {isPaid = True} = Nothing
invoiceEmail isReminder Invoice {rows, reference, account, recipient, due, subject, message, isPaid = False} = Just $ renderInvoice isReminder Invoice {rows, reference, account, recipient, due, subject, message, isPaid = False} = Just $ (subjectPrefix <> " " <> subject,) $
set (headerSubject defaultCharsets) (Just $ subjectPrefix <> " " <> subject ) $ createTextPlainMessage $
(if isReminder then "Muistutus alla olevan laskun maksamisesta. Jos olet juuri maksanut kyseisen laskun, tämä muistutus on aiheeton.\n\n" else mempty) (if isReminder then "Muistutus alla olevan laskun maksamisesta. Jos olet juuri maksanut kyseisen laskun, tämä muistutus on aiheeton.\n\n" else mempty)
<> (if T.null message then mempty else (message <> "\n\n\n")) <> (if T.null message then mempty else (message <> "\n\n\n"))
<> sconcat (NE.map renderInvoiceRow rows) <> "\n" <> sconcat (NE.map renderInvoiceRow rows) <> "\n"

View File

@ -32,6 +32,7 @@ data SendOptions = SendOptions
, email :: Address , email :: Address
, sendmail :: FilePath , sendmail :: FilePath
, reminders :: Bool , reminders :: Bool
, dryRun :: Bool
} }
parseOptions :: IO Options parseOptions :: IO Options
@ -60,3 +61,4 @@ sendOptions = fmap Send $ SendOptions
(long "email" <> help "Invoice sender email address" <> metavar "EMAIL") (long "email" <> help "Invoice sender email address" <> metavar "EMAIL")
<*> strOption (long "sendmail" <> short 'm' <> metavar "FILE" <> help "The sendmail program to use") <*> strOption (long "sendmail" <> short 'm' <> metavar "FILE" <> help "The sendmail program to use")
<*> switch (long "reminders" <> short 'r' <> help "Send reminder emails") <*> switch (long "reminders" <> short 'r' <> help "Send reminder emails")
<*> switch (long "dry-run" <> short 'd' <> help "Only print what invoices would be sent. Do not send anything")