commit ff5137d7d7c43c8537b4cc3d89f84864aa8f2735 Author: Saku Laesvuori Date: Mon Nov 13 09:40:12 2023 +0200 Ensimmäinen versio diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..0173747 --- /dev/null +++ b/guix.scm @@ -0,0 +1,99 @@ +(define-module (laskutin-package) + #:use-module (guix) + #:use-module (guix build-system haskell) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix packages) + #:use-module (gnu packages haskell) + #:use-module (gnu packages haskell-check) + #:use-module (gnu packages haskell-xyz)) + +(define-public laskutin + (package + (name "laskutin") + (version "0.0.1") + (source (local-file "." "laskutin-checkout" + #:recursive? #t)) + (build-system haskell-build-system) + (inputs (list ghc-cassava + ghc-lens + ghc-optparse-applicative + ghc-purebred-email)) + (home-page "https://git.datat.fi/ry/laskutin") + (synopsis "Simple mass invoicing program based on email and CSV") + (description "Laskutin is a simple program for sending and managing lots +invoices. Invoices are defined as rows in a CSV file and all state is stored +back into the file.") + (license license:agpl3+))) + +;;; ghc-purebred-email + +(define ghc-concise + (package + (name "ghc-concise") + (version "0.1.0.1") + (source (origin + (method url-fetch) + (uri (hackage-uri "concise" version)) + (sha256 + (base32 + "09crgc6gjfidlad6263253xx1di6wfhc9awhira21s0z7rddy9sw")))) + (build-system haskell-build-system) + (properties '((upstream-name . "concise"))) + (inputs (list ghc-lens)) + (native-inputs (list ghc-tasty ghc-tasty-quickcheck ghc-quickcheck + ghc-quickcheck-instances)) + (home-page "https://github.com/frasertweedale/hs-concise") + (synopsis "Utilities for Control.Lens.Cons") + (description + "concise provides a handful of functions to extend what you can do with + Control.Lens.Cons.") + (license license:bsd-3))) + +(define ghc-purebred-email + (package + (name "ghc-purebred-email") + (version "0.6.0.1") + (source (origin + (method url-fetch) + (uri (hackage-uri "purebred-email" version)) + (sha256 + (base32 + "0gdzdbxgsyps8hqd903bsyja0cr6kbklkicvma62q48wv0y7230j")))) + (build-system haskell-build-system) + (properties '((upstream-name . "purebred-email"))) + (inputs (list ghc-attoparsec + ghc-case-insensitive + ghc-lens + ghc-base64-bytestring + ghc-concise + ghc-random + ghc-semigroupoids + ghc-stringsearch)) + (native-inputs (list ghc-tasty + ghc-tasty-hedgehog + ghc-tasty-quickcheck + ghc-tasty-hunit + ghc-tasty-golden + ghc-hedgehog + ghc-quickcheck-instances)) + (home-page "https://github.com/purebred-mua/purebred-email") + (synopsis "types and parser for email messages (including MIME)") + (description + "The purebred email library. RFC 5322, MIME, etc. See \"Data.MIME\" for usage, +examples and API documentation. . This is a general-purpose library for +processing and constructing email messages, originally written to meet the needs +of . Transmission and +delivery of mail are not part of this library, but /purebred-email/ could be a +useful building block for such systems. . Features and implemented +specifications include: . - +message parsing and serialisation - MIME multipart messages +() - Convenient APIs for replying +and forward/bounce - Content transfer and charset decoding/encoding - MIME +message header extensions for non-ASCII text +() - MIME parameter value and +encoded word extensions () - +@@Content-Disposition@@ header field () - Address syntax in @@From@@ and @@Sender@@ fields + ()") + (license license:agpl3+))) + +laskutin diff --git a/src/Laskutin.hs b/src/Laskutin.hs new file mode 100644 index 0000000..2a862bd --- /dev/null +++ b/src/Laskutin.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Laskutin where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_, forM) +import Data.Csv (encodeByName) +import Data.List.NonEmpty (nonEmpty) +import Data.MIME (Address, renderAddresses) +import Data.Maybe (catMaybes, mapMaybe) +import Data.Text.Encoding (decodeUtf8) +import System.Exit (exitFailure) +import System.IO (stderr, hPutStrLn) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.IO as T + +import Laskutin.CSV +import Laskutin.Email +import Laskutin.Options +import Laskutin.Types + +main :: IO () +main = do + Options {csv, command} <- parseOptions + case command of + Send sendOptions -> sendInvoicesMain csv sendOptions + UpdateTable bankCsv -> updateTableMain csv bankCsv + +sendInvoicesMain :: FilePath -> SendOptions -> IO () +sendInvoicesMain csvPath options@SendOptions {email, sendmail} = do + invoices <- readInvoices csvPath options + forM_ invoices $ \invoice@(address, _) -> do + sendEmail sendmail $ uncurry (renderEmail [email]) invoice + putStr "Lähetetty osoitteeseen: " + T.putStrLn $ decodeUtf8 $ renderAddresses address + threadDelay (3 * 1000 * 1000) + +updateTableMain :: FilePath -> FilePath -> IO () +updateTableMain invoiceCsv transactionCsv = do + (headers, csvInvoices) <- parseCsvFile invoiceCsv + (_, csvTransactions) <- parseCsvFile transactionCsv + let newInvoices = fmap (updateInvoices csvTransactions) csvInvoices + LBS.writeFile invoiceCsv $ encodeByName headers newInvoices + +updateInvoices :: [CsvTransaction] -> CsvInvoice -> CsvInvoice +updateInvoices transactions invoice@CsvInvoice {isPaid, reference} + | isPaid = invoice + | otherwise = invoice {isPaid = reference `elem` transactionReferences} + where transactionReferences = catMaybes $ transactionReference <$> transactions + transactionReference CsvTransaction {referenceOrMessage = Message _} = Nothing + transactionReference CsvTransaction {referenceOrMessage = Reference ref} = Just ref + +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 $ + nonEmpty $ mapMaybe invoiceRowFromCsv rows + pure ([invoiceRecipient], Invoice { rows = invoiceRows, ..}) diff --git a/src/Laskutin/CSV.hs b/src/Laskutin/CSV.hs new file mode 100644 index 0000000..b92ff59 --- /dev/null +++ b/src/Laskutin/CSV.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Laskutin.CSV (CsvInvoice(..), CsvTransaction(..), TransactionMessage(..), parseCsvFile, invoiceRowFromCsv) where + +import Data.Bifunctor (first) +import Data.Bifunctor (second) +import Control.Monad ((>=>)) +import Data.HashMap.Strict (delete) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.MIME (Address, address, renderAddress, defaultCharsets, parse) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time (Day) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.Vector (Vector, toList) +import System.Exit (exitFailure) +import System.IO (stderr, hPutStrLn) + +import Data.Csv + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.List.NonEmpty as NE + +import Laskutin.Types + +data CsvInvoice = CsvInvoice + { invoiceRecipient :: Address + , reference :: Reference + , isPaid :: Bool + , rows :: [CsvInvoiceRow] + } deriving Show + +data CsvInvoiceRow = CsvInvoiceRow + { amount :: Maybe Euro + , name :: Text + } deriving Show + +data CsvTransaction = CsvTransaction + { date :: Day + , transactor :: Text + , referenceOrMessage :: TransactionMessage + , transactionType :: Text + , amount :: Euro + } deriving Show + +data TransactionMessage = Message Text + | Reference Reference + deriving Show + +instance FromField Address where + parseField field = either (const $ fail $ "Invalid email: " <> show field) pure $ parse (address defaultCharsets) field + +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 + +instance FromField TransactionMessage where + parseField field' = + let field = decodeUtf8 field' + in case readReference $ T.unpack field of + Just reference -> pure $ Reference reference + Nothing -> pure $ Message field + +instance FromNamedRecord CsvInvoice where + parseNamedRecord row = CsvInvoice + <$> row .: emailField + <*> row .: referenceField + <*> row .: paidField + <*> namedRecordToRows (foldr delete row [emailField, referenceField, paidField]) + +instance ToNamedRecord CsvInvoice where + toNamedRecord CsvInvoice {invoiceRecipient, reference, isPaid, rows} = namedRecord $ + [ emailField .= invoiceRecipient + , referenceField .= reference + , paidField .= isPaid + ] <> (invoiceRowToField <$> rows) + +invoiceRowToField :: CsvInvoiceRow -> (BS.ByteString, BS.ByteString) +invoiceRowToField CsvInvoiceRow {amount, name} = encodeUtf8 name .= amount + +instance FromNamedRecord CsvTransaction where + parseNamedRecord row = CsvTransaction + <$> row .: encodeUtf8 "Päivämäärä" + <*> row .: encodeUtf8 "Maksaja tai saaja" + <*> row .: encodeUtf8 "Viite tai viesti" + <*> row .: encodeUtf8 "Selite" + <*> row .: encodeUtf8 "Määrä EUR" + +namedRecordToRows :: NamedRecord -> Parser [CsvInvoiceRow] +namedRecordToRows row = pure + $ fmap (uncurry (flip CsvInvoiceRow) . first decodeUtf8) + $ HM.toList + $ fmap (readEuro . decodeUtf8) row + +emailField, referenceField, paidField :: BS.ByteString +emailField = "sposti" +referenceField = "viite" +paidField = "maksettu" + +handleParseErrors :: Either String (a, Vector b) -> IO (a, [b]) +handleParseErrors = either (hPutStrLn stderr >=> const exitFailure) (pure . second toList) + +parseCsvFile :: FromNamedRecord a => FilePath -> IO (Header, [a]) +parseCsvFile = LBS.readFile >=> handleParseErrors . decodeByName + +invoiceRowFromCsv :: CsvInvoiceRow -> Maybe InvoiceRow +invoiceRowFromCsv CsvInvoiceRow {amount, name} = + maybe Nothing (\amount -> Just InvoiceRow {name, amount}) amount diff --git a/src/Laskutin/Email.hs b/src/Laskutin/Email.hs new file mode 100644 index 0000000..7e472b2 --- /dev/null +++ b/src/Laskutin/Email.hs @@ -0,0 +1,55 @@ +{-# 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 :: [Address] -> [Address] -> Invoice -> ByteString +renderEmail senders recipients = renderMessage + . set (headerBCC defaultCharsets) senders + . set (headerTo defaultCharsets) recipients + . set (headerFrom defaultCharsets) senders + . invoiceEmail + +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 :: Invoice -> MIMEMessage +invoiceEmail Invoice {rows, reference, account, recipient, due, subject, message} = + set (headerSubject defaultCharsets) (Just $ "Lasku – " <> subject ) $ createTextPlainMessage $ + (if T.null message then mempty else (message <> "\n\n\n")) + <> sconcat (NE.map renderInvoiceRow rows) <> "\n" + <> renderInvoiceRow InvoiceRow {name = "YHTEENSÄ", amount = sum $ invoiceRowAmount <$> 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 invoiceRowAmount InvoiceRow {amount} = amount + renderDay (YearMonthDay year month day) = + T.pack $ show day <> "." <> show month <> "." <> show year + +renderInvoiceRow :: InvoiceRow -> Text +renderInvoiceRow InvoiceRow {name, amount} = name <> ": " <> renderEuro amount <> "\n" diff --git a/src/Laskutin/Options.hs b/src/Laskutin/Options.hs new file mode 100644 index 0000000..1626cc5 --- /dev/null +++ b/src/Laskutin/Options.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Laskutin.Options (Options(..), SendOptions(..), Command(..), parseOptions) where + +import Data.Text (Text) +import Data.Time (Day) +import Data.MIME (Address, address, defaultCharsets, parse) + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Options.Applicative + +import Laskutin.Types + +data Options = Options + { csv :: FilePath + , command :: Command + } + +data Command = Send SendOptions + | UpdateTable FilePath + +data SendOptions = SendOptions + { account :: IBAN + , recipient :: Text + , subject :: Text + , message :: Text + , due :: Maybe Day + , email :: Address + , sendmail :: FilePath + } + +parseOptions :: IO Options +parseOptions = execParser $ info (options <**> helper) + (fullDesc <> progDesc "Send email invoices from CSV" <> header "laskutin - email invoice sender") + +options :: Parser Options +options = Options + <$> strOption (long "file" <> help "Path to the csv file" <> metavar "FILE") + <*> subparser + (command "send" (info (sendOptions <**> helper) (progDesc "Send email invoices from CSV")) + <> command "update" (info (updateTableOptions <**> helper) (progDesc "Update invoice CSV from a bank CSV"))) + +updateTableOptions :: Parser Command +updateTableOptions = UpdateTable <$> strOption (long "bank-csv" <> metavar "FILE") + +sendOptions :: Parser Command +sendOptions = fmap Send $ SendOptions + <$> option (maybeReader $ readIBAN . T.pack) (long "iban" <> help "IBAN account" <> metavar "IBAN") + <*> strOption (long "recipient" <> help "The recipient of the payments" <> metavar "TEXT") + <*> strOption (long "subject" <> help "Subject of the invoice" <> metavar "TEXT") + <*> strOption (long "message" <> help "Additional message" <> value "" <> metavar "TEXT") + <*> optional (option auto (long "due" <> help "Due date in YYYY-MM-DD format" <> metavar "DATE")) + <*> option (eitherReader $ parse (address defaultCharsets) . T.encodeUtf8 . T.pack) + (long "email" <> help "Invoice sender email address" <> metavar "EMAIL") + <*> strOption (long "sendmail" <> short 'm' <> metavar "FILE" <> help "The sendmail program to use") diff --git a/src/Laskutin/Types.hs b/src/Laskutin/Types.hs new file mode 100644 index 0000000..d9c627d --- /dev/null +++ b/src/Laskutin/Types.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Laskutin.Types + ( InvoiceRow(..) + , Euro + , IBAN + , Invoice(..) + , Reference + , createReference + , readEuro + , readIBAN + , readReference + , renderEuro + , renderIBAN + , renderReference + ) where + +import Control.Monad (guard) +import Data.Char (isSpace, isDigit, toUpper) +import Data.List.NonEmpty (NonEmpty) +import Data.Ratio (numerator, denominator) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time (Day) +import Data.Csv (FromField(..), ToField(..)) +import Data.Maybe (fromMaybe) + +import qualified Data.Text as T + +data InvoiceRow = InvoiceRow + { amount :: Euro + , name :: Text + } deriving (Show, Eq) + +data Invoice = Invoice + { rows :: NonEmpty InvoiceRow + , reference :: Reference + , account :: IBAN + , recipient :: Text + , subject :: Text + , message :: Text + , due :: Maybe Day + } deriving (Show, Eq) + +data Reference = Reference {base :: [Digit], checksum :: Digit} + deriving (Show, Eq) + +data Digit = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9 + deriving (Show, Eq) + +data IBAN = IBAN {country :: Text, checksum :: (Digit, Digit), account :: Text} + deriving (Show, Eq) + +newtype Euro = Euro Integer -- Cents + deriving (Eq, Ord, Show) + +readIBAN :: Text -> Maybe IBAN +readIBAN text = do + let text' = T.map toUpper $ T.filter (not . isSpace) text + guard $ T.all ((||) <$> isDigit <*> (`elem` ['A'..'Z'])) text' + let (country, rest) = T.splitAt 2 text' + (checksum', account) = T.splitAt 2 rest + guard $ T.length country == 2 + [a,b] <- sequence $ readDigit <$> T.unpack checksum' + let checksum = (a,b) + guard $ T.length account <= 30 -- TODO: this could check some country specific lengths + let str = T.unpack $ account <> country <> checksum' + charToNum c + | isDigit c = [c] + | otherwise = show $ fromEnum c - fromEnum 'A' + 10 + remainder = read (concatMap charToNum str) `mod` 97 + guard $ remainder == (1 :: Integer) + pure IBAN {country, checksum, account} + +renderIBAN :: IBAN -> Text +renderIBAN IBAN {country, checksum, account} = + T.unwords $ T.chunksOf 4 $ country <> renderedChecksum <> account + where renderedChecksum = let (a,b) = checksum in T.pack $ renderDigit <$> [a,b] + +createReference :: String -> Maybe Reference +createReference s = do + base <- sequence $ readDigit <$> s + guard $ length base >= 3 + let checksum = computeReferenceChecksum base + pure Reference {base, checksum} + +readReference :: String -> Maybe Reference +readReference s = do + digits <- sequence $ readDigit <$> filter (not . isSpace) s + guard $ length digits >= 4 + let checksum = last digits + base = init digits + guard $ computeReferenceChecksum base == checksum + pure $ Reference {checksum, base} + +computeReferenceChecksum :: [Digit] -> Digit +computeReferenceChecksum base = + let checksum' = (`mod` 10) $ sum $ zipWith (*) (digitToInt <$> reverse base) (cycle [7,3,1]) + in fromMaybe (error "Impossible") $ intToDigit $ if checksum' == 0 then 0 else 10-checksum' + +renderReference :: Reference -> Text +renderReference Reference {base, checksum} = T.pack $ (renderDigit <$> base) <> [renderDigit checksum] + +renderReferenceBase :: Reference -> Text +renderReferenceBase Reference {base} = T.pack $ renderDigit <$> base + +euroToCents :: Euro -> Integer +euroToCents (Euro a) = a + +renderEuro :: Euro -> Text +renderEuro = do + euros <- T.pack . show . (`div` 100) . euroToCents + cents <- T.justifyRight 2 '0' . T.pack . show . (`mod` 100) . euroToCents + pure $ euros <> "," <> cents <> "€" + -- TODO: Test with negative euros + +readEuro :: Text -> Maybe Euro +readEuro text'' = do + guard $ not $ T.null text'' + let text' = if T.last text'' == '€' then T.init text'' else text'' + (sign, text) = if T.head text' == '-' then (negate, T.tail text') else (id, text') + guard $ T.all (\c -> c `elem` (",." :: [Char]) || isSpace c || isDigit c) text + sign <$> case T.split (`elem` (",." :: [Char])) $ T.filter (not . isSpace) text of + [euros, cents] -> do + guard $ T.length cents <= 2 + pure $ Euro (100 * read (T.unpack euros)) + Euro (read $ T.unpack $ T.justifyLeft 2 '0' cents) + [euros] -> pure $ Euro (100 * read (T.unpack euros)) + _ -> Nothing + +-- XXX: Do these instances make any sense. Multiplying euros with euros is quite weird +instance Num Euro where + (Euro a) + (Euro b) = Euro (a + b) + (Euro a) * (Euro b) = Euro (a * b `div` 100) + abs (Euro a) = Euro (abs a) + signum (Euro a) = Euro (signum a) + negate (Euro a) = Euro (negate a) + fromInteger x = Euro (fromInteger x * 100) + +instance Fractional Euro where + fromRational rational = Euro $ (numerator rational * 100) `div` denominator rational + (Euro a) / (Euro b) = Euro $ (a * 100) `div` b + +instance FromField Reference where + parseField field = maybe (fail $ "Invalid reference: " <> show field) pure $ + createReference $ T.unpack $ decodeUtf8 field + +instance ToField Reference where + toField = encodeUtf8 . renderReferenceBase + +instance FromField Euro where + parseField field = maybe (fail $ "Invalid euro field: " <> show field) pure $ + readEuro $ decodeUtf8 field + +instance ToField Euro where + toField = encodeUtf8 . renderEuro + +readDigit :: Char -> Maybe Digit +readDigit '0' = Just D0 +readDigit '1' = Just D1 +readDigit '2' = Just D2 +readDigit '3' = Just D3 +readDigit '4' = Just D4 +readDigit '5' = Just D5 +readDigit '6' = Just D6 +readDigit '7' = Just D7 +readDigit '8' = Just D8 +readDigit '9' = Just D9 +readDigit _ = Nothing + +renderDigit :: Digit -> Char +renderDigit D0 = '0' +renderDigit D1 = '1' +renderDigit D2 = '2' +renderDigit D3 = '3' +renderDigit D4 = '4' +renderDigit D5 = '5' +renderDigit D6 = '6' +renderDigit D7 = '7' +renderDigit D8 = '8' +renderDigit D9 = '9' + +digitToInt :: Digit -> Int +digitToInt digit = read [renderDigit digit] + +intToDigit :: Int -> Maybe Digit +intToDigit x = case show x of + [c] -> readDigit c + _ -> Nothing diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..44bd2e8 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Laskutin + +main :: IO () +main = Laskutin.main