63 lines
2.9 KiB
Haskell
63 lines
2.9 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
||
|
||
module Laskutin.Email where
|
||
|
||
import Data.Text (Text)
|
||
import Data.MIME (MIMEMessage, Address, createTextPlainMessage, defaultCharsets, headerSubject, headerFrom, headerTo, headerBCC, renderMessage)
|
||
import Control.Lens (set)
|
||
import Data.Semigroup (sconcat)
|
||
import Data.Time.Calendar
|
||
import Data.ByteString.Lazy (ByteString)
|
||
import System.Process (CreateProcess(..), StdStream(..), createProcess, proc, waitForProcess)
|
||
import System.Exit (ExitCode(..))
|
||
import System.IO (hClose)
|
||
import Control.Exception (ErrorCall(..), throwIO)
|
||
|
||
import qualified Data.List.NonEmpty as NE
|
||
import qualified Data.Text as T
|
||
import qualified Data.ByteString.Lazy as LBS
|
||
|
||
import Laskutin.Types
|
||
|
||
renderEmail :: Bool -> [Address] -> [Address] -> Invoice -> ByteString
|
||
renderEmail isReminder senders recipients = renderMessage
|
||
. set (headerBCC defaultCharsets) senders
|
||
. set (headerTo defaultCharsets) recipients
|
||
. set (headerFrom defaultCharsets) senders
|
||
. invoiceEmail isReminder
|
||
|
||
sendEmail :: FilePath -> ByteString -> IO ()
|
||
sendEmail sendmail email = do
|
||
(Just sendmailStdin, _, _, sendmailProcess) <- createProcess (proc sendmail ["-t"]) {std_in = CreatePipe}
|
||
LBS.hPut sendmailStdin email
|
||
hClose sendmailStdin
|
||
exitCode <- waitForProcess sendmailProcess
|
||
case exitCode of
|
||
ExitSuccess -> pure ()
|
||
ExitFailure code -> throwIO $ ErrorCall ("sendmail exited with error code " <> show code)
|
||
|
||
invoiceEmail :: Bool -> Invoice -> MIMEMessage
|
||
invoiceEmail isReminder Invoice {rows, reference, account, recipient, due, subject, message} =
|
||
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 T.null message then mempty else (message <> "\n\n\n"))
|
||
<> sconcat (NE.map renderInvoiceRow rows) <> "\n"
|
||
<> renderInvoiceRow InvoiceRow {name = "YHTEENSÄ", amount = 1, price = sum $ invoiceRowSum <$> rows} <> "\n"
|
||
<> "Maksu tilisiirrolla\n\n"
|
||
<> "Viitenumero: " <> renderReference reference <> "\n"
|
||
<> "Tilinumero: " <> renderIBAN account <> "\n"
|
||
<> "Vastaanottaja: " <> recipient <> "\n"
|
||
<> maybe mempty (("Eräpäivä: " <>) . renderDay) due
|
||
where renderDay (YearMonthDay year month day) =
|
||
T.pack $ show day <> "." <> show month <> "." <> show year
|
||
subjectPrefix = if isReminder then "Maksumuistutus" else "Lasku"
|
||
|
||
invoiceRowSum :: InvoiceRow -> Euro
|
||
invoiceRowSum InvoiceRow {amount, price} = fromIntegral amount * price
|
||
|
||
renderInvoiceRow :: InvoiceRow -> Text
|
||
renderInvoiceRow row@InvoiceRow {name, price, amount}
|
||
| amount > 1 = name <> ", " <> renderEuro price <> "/kpl * " <> T.pack (show amount) <> "kpl: " <> renderEuro (invoiceRowSum row) <> "\n"
|
||
| amount == 1 = name <> ": " <> renderEuro price <> "\n"
|
||
| otherwise = ""
|