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