From 8bd1753539e3540219eafe4afc7f78ec4c3ccdd7 Mon Sep 17 00:00:00 2001 From: Saku Laesvuori Date: Fri, 24 Nov 2023 14:15:59 +0200 Subject: [PATCH] =?UTF-8?q?Tarkista=20ett=C3=A4=20maksut=20ovat=20tarpeeks?= =?UTF-8?q?i=20suuria?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Laskutin.hs | 31 ++++++++++++++++++------------- src/Laskutin/CSV.hs | 30 ++++++++++++++++-------------- src/Laskutin/Email.hs | 11 ++++++----- 3 files changed, 40 insertions(+), 32 deletions(-) diff --git a/src/Laskutin.hs b/src/Laskutin.hs index 3ccd1ce..e733e66 100644 --- a/src/Laskutin.hs +++ b/src/Laskutin.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Laskutin where @@ -7,9 +8,9 @@ module Laskutin where import Control.Concurrent (threadDelay) import Control.Monad (forM_, forM) import Data.Csv (encodeByName) -import Data.List.NonEmpty (nonEmpty) +import Data.List.NonEmpty (nonEmpty, singleton) import Data.MIME (Address, renderAddresses) -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text.Encoding (decodeUtf8) import System.Exit (exitFailure) import System.IO (stderr, hPutStrLn) @@ -31,9 +32,9 @@ main = do sendInvoicesMain :: FilePath -> SendOptions -> IO () sendInvoicesMain csvPath options@SendOptions {email, sendmail, reminders} = do - invoices <- filter (\(_, Invoice {isPaid}) -> not isPaid) <$> readInvoices csvPath options - forM_ invoices $ \invoice@(address, _) -> do - sendEmail sendmail $ uncurry (renderEmail reminders [email]) invoice + invoices <- mapMaybe (\(address, invoice) -> (address,) <$> renderEmail reminders [email] address invoice) <$> readInvoices csvPath options + forM_ invoices $ \(address, invoiceMail) -> do + sendEmail sendmail invoiceMail putStr "Lähetetty osoitteeseen: " T.putStrLn $ decodeUtf8 $ renderAddresses address threadDelay (3 * 1000 * 1000) @@ -46,17 +47,21 @@ updateTableMain invoiceCsv transactionCsv = do LBS.writeFile invoiceCsv $ encodeByName headers newInvoices updateInvoices :: [CsvTransaction] -> CsvInvoice -> CsvInvoice -updateInvoices transactions invoice@CsvInvoice {isPaid, reference, ..} - | isPaid = invoice - | otherwise = CsvInvoice {isPaid = reference `elem` transactionReferences, ..} - where transactionReferences = catMaybes $ transactionReference <$> transactions - transactionReference CsvTransaction {referenceOrMessage = Message _} = Nothing - transactionReference CsvTransaction {referenceOrMessage = Reference ref} = Just ref +updateInvoices transactions invoice@CsvInvoice {reference, ..} + | csvIsPaid invoice = invoice + | otherwise = CsvInvoice {paid = Just transactionsSum, ..} + where transactionsSum = sum $ map amount $ filter hasReference transactions + hasReference CsvTransaction {referenceOrMessage = Reference ref} = reference == ref + hasReference CsvTransaction {referenceOrMessage = Message _} = False readInvoices :: FilePath -> SendOptions -> IO [([Address], Invoice)] readInvoices csv SendOptions {account, recipient, subject, message, due} = do (_, csvInvoices) <- parseCsvFile csv - forM csvInvoices $ \CsvInvoice {..} -> do - invoiceRows <- maybe (hPutStrLn stderr ("No invoice rows in invoice") >> exitFailure) pure $ + forM csvInvoices $ \csvInvoice@CsvInvoice {..} -> do + invoiceRows' <- maybe (hPutStrLn stderr ("No invoice rows in invoice") >> exitFailure) pure $ nonEmpty $ mapMaybe invoiceRowFromCsv rows + let isPaid = fromMaybe 0 paid >= csvInvoiceSum csvInvoice + invoiceRows = case paid of + Nothing -> invoiceRows' + Just euro -> invoiceRows' <> singleton InvoiceRow {name = "Aiemmin maksettu", amount = 1, price = negate euro} pure ([invoiceRecipient], Invoice { rows = invoiceRows, ..}) diff --git a/src/Laskutin/CSV.hs b/src/Laskutin/CSV.hs index 9d9c58c..d968f90 100644 --- a/src/Laskutin/CSV.hs +++ b/src/Laskutin/CSV.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-} -module Laskutin.CSV (CsvInvoice(..), CsvTransaction(..), TransactionMessage(..), parseCsvFile, invoiceRowFromCsv) where +module Laskutin.CSV (CsvInvoice(..), CsvTransaction(..), TransactionMessage(..), csvInvoiceSum, csvInvoiceRowSum, csvIsPaid, parseCsvFile, invoiceRowFromCsv) where import Data.Bifunctor (bimap, second) import Control.Monad ((>=>), guard) @@ -29,7 +29,7 @@ import Laskutin.Types data CsvInvoice = CsvInvoice { invoiceRecipient :: Address , reference :: Reference - , isPaid :: Bool + , paid :: Maybe Euro , rows :: [CsvInvoiceRow] } deriving Show @@ -47,6 +47,16 @@ data CsvTransaction = CsvTransaction , amount :: Euro } deriving Show +csvIsPaid :: CsvInvoice -> Bool +csvIsPaid CsvInvoice {paid = Nothing} = False +csvIsPaid invoice@CsvInvoice {paid = Just paid} = paid >= csvInvoiceSum invoice + +csvInvoiceSum :: CsvInvoice -> Euro +csvInvoiceSum CsvInvoice {rows} = sum $ csvInvoiceRowSum <$> rows + +csvInvoiceRowSum :: CsvInvoiceRow -> Euro +csvInvoiceRowSum CsvInvoiceRow {amount, price} = maybe 0 ((* price) . fromIntegral) amount + data TransactionMessage = Message Text | Reference Reference deriving Show @@ -57,14 +67,6 @@ instance FromField Address where instance ToField Address where toField = renderAddress -instance FromField Bool where - parseField "x" = pure True - parseField _ = pure False - -instance ToField Bool where - toField True = "x" - toField False = "" - instance FromField Day where parseField = iso8601ParseM . T.unpack . decodeUtf8 @@ -83,14 +85,14 @@ instance FromNamedRecord CsvInvoice where <*> namedRecordToRows (foldr delete row [emailField, referenceField, paidField]) instance ToNamedRecord CsvInvoice where - toNamedRecord CsvInvoice {invoiceRecipient, reference, isPaid, rows} = namedRecord $ + toNamedRecord CsvInvoice {invoiceRecipient, reference, paid, rows} = namedRecord $ [ emailField .= invoiceRecipient , referenceField .= reference - , paidField .= isPaid + , paidField .= paid ] <> (invoiceRowToField <$> rows) invoiceRowToField :: CsvInvoiceRow -> (BS.ByteString, BS.ByteString) -invoiceRowToField CsvInvoiceRow {amount, name} = encodeUtf8 name .= amount +invoiceRowToField CsvInvoiceRow {amount, price, name} = encodeUtf8 (name <> ":" <> renderEuro price) .= amount instance FromNamedRecord CsvTransaction where parseNamedRecord row = CsvTransaction @@ -111,7 +113,7 @@ namedRecordToRows = mapM (parseInvoiceRow . bimap decodeUtf8 decodeUtf8) . HM.to guard $ T.all isDigit x pure $ read $ T.unpack x readHeader x = do - [name, price'] <- pure $ T.strip <$> T.splitOn ":" x + [name, price'] <- pure $ T.splitOn ":" x price <- readEuro price' pure (name, price) diff --git a/src/Laskutin/Email.hs b/src/Laskutin/Email.hs index 6122778..1e2d09a 100644 --- a/src/Laskutin/Email.hs +++ b/src/Laskutin/Email.hs @@ -19,11 +19,11 @@ import qualified Data.ByteString.Lazy as LBS import Laskutin.Types -renderEmail :: Bool -> [Address] -> [Address] -> Invoice -> ByteString -renderEmail isReminder senders recipients = renderMessage +renderEmail :: Bool -> [Address] -> [Address] -> Invoice -> Maybe ByteString +renderEmail isReminder senders recipients = fmap (renderMessage . set (headerBCC defaultCharsets) senders . set (headerTo defaultCharsets) recipients - . set (headerFrom defaultCharsets) senders + . set (headerFrom defaultCharsets) senders) . invoiceEmail isReminder sendEmail :: FilePath -> ByteString -> IO () @@ -36,8 +36,9 @@ sendEmail sendmail email = do 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} = +invoiceEmail :: Bool -> Invoice -> Maybe MIMEMessage +invoiceEmail _ Invoice {isPaid = True} = Nothing +invoiceEmail isReminder Invoice {rows, reference, account, recipient, due, subject, message, isPaid = False} = Just $ 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"))