71 lines
3.3 KiB
Haskell
71 lines
3.3 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE TupleSections #-}
|
||
|
||
module Laskutin.Email where
|
||
|
||
import Data.Text (Text)
|
||
import Data.MIME (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 :: [Address] -> [Address] -> Text -> Text -> ByteString
|
||
renderEmail senders recipients subject = renderMessage
|
||
. set (headerBCC defaultCharsets) senders
|
||
. set (headerTo defaultCharsets) recipients
|
||
. set (headerFrom defaultCharsets) senders
|
||
. set (headerSubject defaultCharsets) (Just subject)
|
||
. createTextPlainMessage
|
||
|
||
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)
|
||
|
||
renderInvoice :: Bool -> Invoice -> Maybe (Text, Text)
|
||
renderInvoice isReminder invoice@Invoice {rows, reference, account, recipient, due, subject, message, paid}
|
||
| invoiceSum invoice <= 0 && isReminder = Nothing
|
||
| otherwise = Just $ (subjectPrefix <> " – " <> subject,) $
|
||
(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"
|
||
<> (if paid > 0 then renderInvoiceRow InvoiceRow {name = "Aiemmat maksut", amount = 1, price = paid} <> "\n" else mempty)
|
||
<> renderInvoiceRow InvoiceRow {name = "MAKSETTAVAA", amount = 1, price = invoiceSum invoice} <> "\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
|
||
|
||
invoiceSum :: Invoice -> Euro
|
||
invoiceSum Invoice {rows, paid} = subtract paid $ sum $ invoiceRowSum <$> rows
|
||
|
||
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 = ""
|