ENH don't print db lookup errors

This commit is contained in:
Nathan Dwarshuis 2023-01-28 22:55:07 -05:00
parent 95514df295
commit 5e967ae9cb
3 changed files with 104 additions and 101 deletions

View File

@ -1,6 +1,7 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Insert module Internal.Insert
( insertStatements ( insertStatements
@ -16,35 +17,9 @@ import Internal.Statement
import Internal.Types hiding (sign) import Internal.Types hiding (sign)
import Internal.Utils import Internal.Utils
import RIO hiding (to) import RIO hiding (to)
import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v)
lookupKey m k = do
let v = M.lookup k m
when (isNothing v) $
liftIO $
putStrLn $
"key does not exist: " ++ show k
return v
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
lookupAccount p = do
m <- asks kmAccount
lookupKey m p
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR))
lookupAccountKey = fmap (fmap fst) . lookupAccount
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR))
lookupCurrency c = do
m <- asks kmCurrency
lookupKey m c
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- intervals -- intervals
@ -118,8 +93,9 @@ mdyPatternMatches check x p = case p of
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError] insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
insertBudget Budget {income = is, expenses = es} = do insertBudget Budget {income = is, expenses = es} = do
mapM_ insertExpense es es1 <- mapM insertIncome is
concat <$> mapM insertIncome is es2 <- mapM insertExpense es
return $ concat $ es1 ++ es2
-- TODO this hashes twice (not that it really matters) -- TODO this hashes twice (not that it really matters)
whenHash whenHash
@ -140,15 +116,19 @@ insertIncome
{ incCurrency = cur { incCurrency = cur
, incWhen = dp , incWhen = dp
, incAccount = from , incAccount = from
, incTaxes = ts , incTaxes = taxes
} = } =
whenHash CTIncome i [] $ \c -> do whenHash CTIncome i [] $ \c ->
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
unlessLeft (balanceIncome i) $ \balanced -> do unlessLeft (balanceIncome i) $ \balanced -> do
forM_ (expandDatePat bounds dp) $ \day -> do bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
alloTx <- concat <$> mapM (allocationToTx from day) balanced fmap concat $ forM (expandDatePat bounds dp) $ \day -> do
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts -- TODO why are these separate?
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx nontaxRes <- alloTxs concat (allocationToTx from day) balanced
taxRes <- alloTxs (fmap (,Fixed)) (taxToTx from day cur) taxes
unlessLefts_ (concatEithers2 nontaxRes taxRes (++)) $ \txs ->
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) txs
where
alloTxs squish toTx = fmap (fmap squish . concatEithersL) . mapM toTx
balanceIncome :: Income -> EitherErr [BalAllocation] balanceIncome :: Income -> EitherErr [BalAllocation]
balanceIncome balanceIncome
@ -202,7 +182,7 @@ allocationToTx
=> AcntID => AcntID
-> Day -> Day
-> BalAllocation -> BalAllocation
-> MappingT m [(KeyTx, Bucket)] -> MappingT m (EitherErrs [(KeyTx, Bucket)])
allocationToTx allocationToTx
from from
day day
@ -212,9 +192,15 @@ allocationToTx
, alloCurrency = cur , alloCurrency = cur
, alloAmts = as , alloAmts = as
} = } =
fmap (,b) <$> mapM (transferToTx day from to cur) as second (fmap (,b)) . concatEithersL <$> mapM (transferToTx day from to cur) as
taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx taxToTx
:: MonadUnliftIO m
=> AcntID
-> Day
-> T.Text
-> Tax
-> MappingT m (EitherErrs KeyTx)
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} = taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
txPair day from to cur (dec2Rat v) "" txPair day from to cur (dec2Rat v) ""
@ -225,11 +211,11 @@ transferToTx
-> AcntID -> AcntID
-> T.Text -> T.Text
-> BalAmount -> BalAmount
-> MappingT m KeyTx -> MappingT m (EitherErrs KeyTx)
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} = transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
txPair day from to cur v d txPair day from to cur v d
insertExpense :: MonadUnliftIO m => Expense -> MappingT m () insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
insertExpense insertExpense
e@Expense e@Expense
{ expFrom = from { expFrom = from
@ -238,11 +224,12 @@ insertExpense
, expBucket = buc , expBucket = buc
, expAmounts = as , expAmounts = as
} = do } = do
whenHash CTExpense e () $ \key -> mapM_ (go key) as whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
where where
go key amt = do go key amt = do
keys <- timeAmountToTx from to cur amt res <- timeAmountToTx from to cur amt
lift $ mapM_ (insertTxBucket (Just buc) key) keys unlessLefts_ res $
lift . mapM_ (insertTxBucket (Just buc) key)
timeAmountToTx timeAmountToTx
:: MonadUnliftIO m :: MonadUnliftIO m
@ -250,7 +237,7 @@ timeAmountToTx
-> AcntID -> AcntID
-> CurID -> CurID
-> TimeAmount -> TimeAmount
-> MappingT m [KeyTx] -> MappingT m (EitherErrs [KeyTx])
timeAmountToTx timeAmountToTx
from from
to to
@ -264,7 +251,7 @@ timeAmountToTx
} }
} = do } = do
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
mapM tx $ expandDatePat bounds dp concatEithersL <$> mapM tx (expandDatePat bounds dp)
where where
tx day = txPair day from to cur (dec2Rat v) d tx day = txPair day from to cur (dec2Rat v) d
@ -277,10 +264,10 @@ insertStatements conf = concat <$> mapM insertStatement (statements conf)
-- unless (null es) $ throwIO $ InsertException es -- unless (null es) $ throwIO $ InsertException es
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError] insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
insertStatement (StmtManual m) = insertManual m >> return [] insertStatement (StmtManual m) = insertManual m
insertStatement (StmtImport i) = insertImport i insertStatement (StmtImport i) = insertImport i
insertManual :: MonadUnliftIO m => Manual -> MappingT m () insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
insertManual insertManual
m@Manual m@Manual
{ manualDate = dp { manualDate = dp
@ -290,10 +277,10 @@ insertManual
, manualCurrency = u , manualCurrency = u
, manualDesc = e , manualDesc = e
} = do } = do
whenHash CTManual m () $ \c -> do whenHash CTManual m [] $ \c -> do
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
ts <- mapM tx $ expandDatePat bounds dp res <- mapM tx $ expandDatePat bounds dp
lift $ mapM_ (insertTx c) ts unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
where where
tx day = txPair day from to u (dec2Rat v) e tx day = txPair day from to u (dec2Rat v) e
@ -301,12 +288,15 @@ insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
insertImport i = whenHash CTImport i [] $ \c -> do insertImport i = whenHash CTImport i [] $ \c -> do
-- TODO this isn't efficient, the whole file will be read and maybe no -- TODO this isn't efficient, the whole file will be read and maybe no
-- transactions will be desired -- transactions will be desired
res <- tryIO $ readImport i recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
case res of
Right r -> unlessLefts r $ \bs -> do
bounds <- asks kmStatementInterval bounds <- asks kmStatementInterval
rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs res <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
lift $ mapM_ (insertTx c) rs unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
where
recoverIO x rest = do
res <- tryIO x
case res of
Right r -> rest r
-- If file is not found (or something else happens) then collect the -- If file is not found (or something else happens) then collect the
-- error try the remaining imports -- error try the remaining imports
Left e -> return [InsertIOError $ showT e] Left e -> return [InsertIOError $ showT e]
@ -322,7 +312,7 @@ txPair
-> T.Text -> T.Text
-> Rational -> Rational
-> T.Text -> T.Text
-> MappingT m KeyTx -> MappingT m (EitherErrs KeyTx)
txPair day from to cur val desc = resolveTx tx txPair day from to cur val desc = resolveTx tx
where where
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur} split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@ -334,27 +324,27 @@ txPair day from to cur val desc = resolveTx tx
, txSplits = [split from (-val), split to val] , txSplits = [split from (-val), split to val]
} }
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do resolveTx t@Tx {txSplits = ss} = do
rs <- catMaybes <$> mapM resolveSplit ss res <- concatEithersL <$> mapM resolveSplit ss
return $ t {txSplits = rs} return $ fmap (\kss -> t {txSplits = kss}) res
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe KeySplit) resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
aid <- lookupAccountKey p aid <- lookupAccountKey p
cid <- lookupCurrency c cid <- lookupCurrency c
sign <- lookupAccountSign p sign <- lookupAccountSign p
-- TODO correct sign here? -- TODO correct sign here?
-- TODO lenses would be nice here -- TODO lenses would be nice here
return $ case (aid, cid, sign) of return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
(Just aid', Just cid', Just sign') ->
Just $
s s
{ sAcnt = aid' { sAcnt = aid_
, sCurrency = cid' , sCurrency = cid_
, sValue = v * fromIntegral (sign2Int sign') , sValue = v * fromIntegral (sign2Int sign_)
} }
_ -> Nothing
-- return $ case (aid, cid, sign) of
-- _ -> Nothing
insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m () insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
@ -367,3 +357,15 @@ insertTx = insertTxBucket Nothing
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m () insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
insert_ $ SplitR t cid aid c v insert_ $ SplitR t cid aid c v
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR))
lookupAccountKey = fmap (fmap fst) . lookupAccount
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency

View File

@ -11,6 +11,7 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Types where module Internal.Types where
@ -529,6 +530,7 @@ data LookupSuberr
= SplitIDField SplitIDType = SplitIDField SplitIDType
| SplitValField | SplitValField
| MatchField MatchType | MatchField MatchType
| DBKey SplitIDType
deriving (Show) deriving (Show)
data AllocationSuberr data AllocationSuberr
@ -542,6 +544,7 @@ data InsertError
= RegexError T.Text = RegexError T.Text
| MatchValPrecisionError Natural Natural | MatchValPrecisionError Natural Natural
| InsertIOError T.Text | InsertIOError T.Text
| ParseError T.Text
| ConversionError T.Text | ConversionError T.Text
| LookupError LookupSuberr T.Text | LookupError LookupSuberr T.Text
| BalanceError BalanceType CurID [RawSplit] | BalanceError BalanceType CurID [RawSplit]
@ -556,10 +559,3 @@ instance Exception InsertException
type EitherErr = Either InsertError type EitherErr = Either InsertError
type EitherErrs = Either [InsertError] type EitherErrs = Either [InsertError]
-- type StateErr = State [InsertError]
-- runErrors :: StateErr a -> Either [InsertError] a
-- runErrors x = case runState x [] of
-- (y, []) -> Right y
-- (_, es) -> Left es

View File

@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Utils module Internal.Utils
( compareDate ( compareDate
@ -12,14 +13,20 @@ module Internal.Utils
, leftToMaybe , leftToMaybe
, dec2Rat , dec2Rat
, concatEithers2 , concatEithers2
, concatEither3
, concatEither2 , concatEither2
, concatEitherL
, concatEithersL
, parseRational , parseRational
, showError , showError
, unlessLeft_
, unlessLefts_
, unlessLeft , unlessLeft
, unlessLefts , unlessLefts
, inMaybeBounds , inMaybeBounds
, acntPath2Text , acntPath2Text
, showT , showT
, lookupErr
) )
where where
@ -282,29 +289,21 @@ showError other = (: []) $ case other of
(RegexError re) -> T.append "could not make regex from pattern: " re (RegexError re) -> T.append "could not make regex from pattern: " re
(ConversionError x) -> T.append "Could not convert to rational number: " x (ConversionError x) -> T.append "Could not convert to rational number: " x
(InsertIOError msg) -> T.append "IO Error: " msg (InsertIOError msg) -> T.append "IO Error: " msg
(ParseError msg) -> T.append "Parse Error: " msg
(MatchValPrecisionError d p) -> (MatchValPrecisionError d p) ->
T.unwords ["Match denominator", showT d, "must be less than", showT p] T.unwords ["Match denominator", showT d, "must be less than", showT p]
(LookupError t f) -> (LookupError t f) ->
T.unwords T.unwords ["Could not find field", singleQuote f, "when resolving", what]
[ "Could not find field"
, singleQuote f
, "when resolving"
, what
]
where where
what = case t of what = case t of
SplitIDField st -> SplitIDField st -> T.unwords ["split", idName st, "ID"]
T.unwords
[ "split"
, case st of AcntField -> "account"; CurField -> "currency"
, "ID"
]
SplitValField -> "split value" SplitValField -> "split value"
MatchField mt -> MatchField mt -> T.unwords [matchName mt, "match"]
T.unwords DBKey st -> T.unwords ["database", idName st, "ID key"]
[ case mt of MatchNumeric -> "numeric"; MatchText -> "text" idName AcntField = "account"
, "match" idName CurField = "currency"
] matchName MatchNumeric = "numeric"
matchName MatchText = "text"
(AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp] (AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
where where
msg = case t of msg = case t of
@ -467,13 +466,19 @@ leftToMaybe :: Either a b -> Maybe a
leftToMaybe (Left a) = Just a leftToMaybe (Left a) = Just a
leftToMaybe _ = Nothing leftToMaybe _ = Nothing
unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a) unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
unlessLeft (Left es) _ = return (return es) unlessLeft (Left es) _ = return (return es)
unlessLeft (Right rs) f = f rs >> return mzero unlessLeft (Right rs) f = f rs
unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a) unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a)
unlessLefts (Left es) _ = return es unlessLefts (Left es) _ = return es
unlessLefts (Right rs) f = f rs >> return mzero unlessLefts (Right rs) f = f rs
unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a)
unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
plural :: Either a b -> Either [a] b plural :: Either a b -> Either [a] b
plural = first (: []) plural = first (: [])