Ensimmäinen versio
This commit is contained in:
commit
ff5137d7d7
GPG Key ID:
257D284A2A1D3A32
|
|
@ -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 <https://github.com/purebred-mua/purebred purebred MUA>. 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: . - <https://tools.ietf.org/html/rfc5322 RFC 5322>
|
||||||
|
message parsing and serialisation - MIME multipart messages
|
||||||
|
(<https://tools.ietf.org/html/rfc2046 RFC 2046>) - Convenient APIs for replying
|
||||||
|
and forward/bounce - Content transfer and charset decoding/encoding - MIME
|
||||||
|
message header extensions for non-ASCII text
|
||||||
|
(<https://tools.ietf.org/html/rfc2047 RFC 2047>) - MIME parameter value and
|
||||||
|
encoded word extensions (<https://tools.ietf.org/html/rfc2231 RFC 2231>) -
|
||||||
|
@@Content-Disposition@@ header field (<https://tools.ietf.org/html/rfc2183 RFC 2183>) - Address syntax in @@From@@ and @@Sender@@ fields
|
||||||
|
(<https://tools.ietf.org/html/rfc6854 RFC 6854>)")
|
||||||
|
(license license:agpl3+)))
|
||||||
|
|
||||||
|
laskutin
|
||||||
|
|
@ -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, ..})
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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"
|
||||||
|
|
@ -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")
|
||||||
|
|
@ -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
|
||||||
|
|
@ -0,0 +1,6 @@
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import qualified Laskutin
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = Laskutin.main
|
||||||
Loading…
Reference in New Issue