193 lines
6.1 KiB
Haskell
193 lines
6.1 KiB
Haskell
{-# 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
|
|
{ price :: Euro
|
|
, amount :: Int
|
|
, 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
|