1 files changed, 162 insertions, 0 deletions

diff --git a/app/Import/Ing/SavingsAccountCsv.hs b/app/Import/Ing/SavingsAccountCsv.hs
new file mode 100644
index 0000000..f6632fc
--- /dev/null
+++ b/app/Import/Ing/SavingsAccountCsv.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Import.Ing.SavingsAccountCsv where
+
+import Data.ByteString.Lazy qualified as BS
+import Data.Csv ((.:))
+import Data.Csv qualified as C
+import Data.Decimal (Decimal)
+import Data.Iban (Iban, mkIban)
+import Data.Maybe (isJust)
+import Data.Text qualified as T
+import Data.Time.Calendar (Day)
+import Data.Vector qualified as V
+import Import.Ing.Shared (dateCP, decimalCP, eitherToCP, ibanCP, maybeCP, scsvOptions)
+import System.IO (Handle)
+import Text.Regex.TDFA ((=~~))
+
+data DebitCredit = Debit | Credit deriving (Show, Eq)
+
+data MutationType = DepositMutation | WithdrawalMutation | InterestMutation deriving (Show)
+
+data TxBase = TxBase
+  { txbDate :: !Day,
+    txbAccountId :: !T.Text,
+    txbAccountName :: !T.Text,
+    txbAmount :: !Decimal,
+    txbResBal :: !Decimal
+  }
+  deriving (Show)
+
+data TxSpecifics
+  = Interest
+  | Withdrawal
+      { wToCurrentAccountIban :: !Iban,
+        wDescription :: !T.Text
+      }
+  | Deposit
+      { dFromCurrentAccountIban :: !Iban,
+        dDescription :: !T.Text
+      }
+  | CurrentAccountAutoSaveRounding {caasFromCurrentAccountIban :: !Iban}
+  deriving (Show)
+
+data Tx = Tx TxBase TxSpecifics deriving (Show)
+
+instance MonadFail (Either String) where
+  fail = Left
+
+txBaseFromPrim :: PrimTx -> Either String TxBase
+txBaseFromPrim ptx@PrimTx {ptxCommodity = "EUR"} =
+  return $ TxBase (ptxDate ptx) (ptxAccountId ptx) (ptxAccountName ptx) (ptxAmount ptx) (ptxResBal ptx)
+txBaseFromPrim ptx =
+  Left $ "Unexpected commodity '" ++ T.unpack (ptxCommodity ptx) ++ "' (expected EUR)"
+
+specificsFromPrim :: PrimTx -> Either String TxSpecifics
+specificsFromPrim ptx@PrimTx {ptxMutationType = InterestMutation}
+  | isJust (ptxCounterparty ptx) = Left "Expected no counterparty for interest transaction"
+  | ptxDebitCredit ptx /= Credit =
+      Left "Expected interest transaction to be of credit ('Bij') type, got debit ('Af')"
+  | not (T.null (ptxNotifications ptx)) =
+      Left "Expected no notifications for interest transaction"
+  | ptxDescription ptx /= "Rente" =
+      Left $ "Expected interest transaction to have description 'Rente', got '" ++ T.unpack (ptxDescription ptx) ++ "'"
+  | otherwise = return Interest
+specificsFromPrim ptx@PrimTx {ptxMutationType = WithdrawalMutation} = do
+  let regex = "Overboeking naar betaalrekening (.*)" :: String
+  (_, _, _, [ibanTxt]) <- ptxDescription ptx =~~ regex :: Either String (T.Text, T.Text, T.Text, [T.Text])
+  iban <- mkIban ibanTxt
+  case ptxCounterparty ptx of
+    Nothing -> Left "Expected counterparty for withdrawal transaction"
+    Just cpIban ->
+      if cpIban /= iban
+        then Left "Expected counterparty and IBAN in description to be equal"
+        else return $ Withdrawal {wToCurrentAccountIban = iban, wDescription = ptxNotifications ptx}
+specificsFromPrim ptx@PrimTx {ptxMutationType = DepositMutation} = do
+  let regex = "(Afronding|Overboeking) van betaalrekening (.*)" :: String
+  (_, _, _, [ty, ibanTxt]) <- ptxDescription ptx =~~ regex :: Either String (T.Text, T.Text, T.Text, [T.Text])
+  iban <- mkIban ibanTxt
+  case ptxCounterparty ptx of
+    Nothing -> Left "Expected counterparty for deposit transaction"
+    Just cpIban ->
+      if cpIban /= iban
+        then Left "Expected counterparty and IBAN in description to be equal"
+        else case ty of
+          "Afronding" ->
+            if not (T.null (ptxNotifications ptx))
+              then
+                Left "Expected no notifications for auto-save rounding transaction"
+              else return $ CurrentAccountAutoSaveRounding {caasFromCurrentAccountIban = iban}
+          "Overboeking" ->
+            return $ Deposit {dFromCurrentAccountIban = iban, dDescription = ptxNotifications ptx}
+          _ -> error "unreachable"
+
+processPrimTx :: PrimTx -> Either String Tx
+processPrimTx ptx = Tx <$> txBaseFromPrim ptx <*> specificsFromPrim ptx
+
+data PrimTx = PrimTx
+  { ptxDate :: !Day,
+    ptxDescription :: !T.Text,
+    ptxAccountId :: !T.Text,
+    ptxAccountName :: !T.Text,
+    ptxCounterparty :: !(Maybe Iban),
+    ptxDebitCredit :: !DebitCredit,
+    ptxAmount :: !Decimal,
+    ptxCommodity :: !T.Text,
+    ptxMutationType :: !MutationType,
+    ptxNotifications :: !T.Text,
+    ptxResBal :: !Decimal
+  }
+  deriving (Show)
+
+debitCreditCP :: T.Text -> C.Parser DebitCredit
+debitCreditCP "Af" = return Debit
+debitCreditCP "Bij" = return Credit
+debitCreditCP t = fail ("Unknown debit/credit value '" ++ T.unpack t ++ "'")
+
+mutationTypeCP :: T.Text -> C.Parser MutationType
+mutationTypeCP "Inleg" = return DepositMutation
+mutationTypeCP "Opname" = return WithdrawalMutation
+mutationTypeCP "Rente" = return InterestMutation
+mutationTypeCP t = fail ("Unknown mutation type '" ++ T.unpack t ++ "'")
+
+parseNamedRecord :: C.NamedRecord -> C.Parser Tx
+parseNamedRecord m =
+  eitherToCP . processPrimTx
+    =<< PrimTx
+      <$> (m .: "Datum" >>= dateCP "%Y-%m-%d")
+      <*> m .: "Omschrijving"
+      <*> m .: "Rekening"
+      <*> m .: "Rekening naam"
+      <*> (m .: "Tegenrekening" >>= maybeCP ibanCP)
+      <*> (m .: "Af Bij" >>= debitCreditCP)
+      <*> (m .: "Bedrag" >>= decimalCP)
+      <*> m .: "Valuta"
+      <*> (m .: "Mutatiesoort" >>= mutationTypeCP)
+      <*> m .: "Mededelingen"
+      <*> (m .: "Saldo na mutatie" >>= decimalCP)
+
+readFile :: Handle -> IO (V.Vector Tx)
+readFile h = do
+  contents <- BS.hGetContents h
+  case C.decodeByNameWithP parseNamedRecord scsvOptions contents of
+    Left err -> fail err
+    Right
+      ( [ "Datum",
+          "Omschrijving",
+          "Rekening",
+          "Rekening naam",
+          "Tegenrekening",
+          "Af Bij",
+          "Bedrag",
+          "Valuta",
+          "Mutatiesoort",
+          "Mededelingen",
+          "Saldo na mutatie"
+          ],
+        txs
+        ) ->
+        return txs
+    Right _ ->
+      fail "Headers do not match expected pattern"