ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

FIX don't hash budget components (since they are interdependent)

This commit is contained in:
Nathan Dwarshuis 2023-03-01 20:38:11 -05:00
parent 6e2598b274
commit d89b63e59a
4 changed files with 80 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lib/Internal/Database/Ops.hs
View File

@ -95,14 +95,11 @@ hashConfig
Config_ Config_
{ budget = bs { budget = bs
, statements = ss , statements = ss
} = } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
concatMap budgetHashes bs ++ (hash <$> ms) ++ (hash <$> ps)
where where
(ms, ps) = partitionEithers $ fmap go ss (ms, ps) = partitionEithers $ fmap go ss
go (StmtManual x) = Left x go (StmtManual x) = Left x
go (StmtImport x) = Right x go (StmtImport x) = Right x
budgetHashes Budget {transfers = xs, income = is} =
(hash <$> xs) ++ (hash <$> is)
setDiff :: Eq a => [a] -> [a] -> ([a], [a]) setDiff :: Eq a => [a] -> [a] -> ([a], [a])
-- setDiff = setDiff' (==) -- setDiff = setDiff' (==)

149
lib/Internal/Insert.hs
View File

@ -119,14 +119,15 @@ withDates dp f = do
-- 5. insert all transactions -- 5. insert all transactions
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError] insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss} = do insertBudget b@(Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss}) =
res1 <- mapM (insertIncome name) is whenHash CTBudget b [] $ \key -> do
res2 <- expandTransfers name es res1 <- mapM (insertIncome key name) is
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $ res2 <- expandTransfers key name es
\txs -> do unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
unlessLefts (addShadowTransfers ss txs) $ \shadow -> do \txs -> do
let bals = balanceTransfers $ txs ++ shadow unlessLefts (addShadowTransfers ss txs) $ \shadow -> do
concat <$> mapM insertBudgetTx bals let bals = balanceTransfers $ txs ++ shadow
concat <$> mapM insertBudgetTx bals
-- TODO this is going to be O(n*m), which might be a problem? -- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType] addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType]
@ -173,13 +174,15 @@ shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
(if asInclude then id else not) $ x `elem` asList (if asInclude then id else not) $ x `elem` asList
balanceTransfers :: [BudgetTxType] -> [BudgetTx] balanceTransfers :: [BudgetTxType] -> [BudgetTx]
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts balanceTransfers ts =
snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts
where where
initBals = initBals =
M.fromList $ M.fromList $
fmap (,0) $ fmap (,0) $
L.nub $ L.nub $
(fmap (btTo . bttTx) ts ++ fmap (btTo . bttTx) ts) fmap (btTo . bttTx) ts
++ fmap (btFrom . bttTx) ts
updateBal x = M.update (Just . (+ x)) updateBal x = M.update (Just . (+ x))
lookupBal = M.findWithDefault (error "this should not happen") lookupBal = M.findWithDefault (error "this should not happen")
go bals btt = go bals btt =
@ -197,7 +200,7 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
amtToMove bal Target x = x - bal amtToMove bal Target x = x - bal
data BudgetMeta = BudgetMeta data BudgetMeta = BudgetMeta
{ bmCommit :: !(Key CommitR) { bmCommit :: !CommitRId
, bmCur :: !BudgetCurrency , bmCur :: !BudgetCurrency
, bmName :: !T.Text , bmName :: !T.Text
} }
@ -216,40 +219,41 @@ data BudgetTxType = BudgetTxType
, bttTx :: !BudgetTx , bttTx :: !BudgetTx
} }
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType]) insertIncome :: MonadFinance m => CommitRId -> T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType])
insertIncome insertIncome
key
name name
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do
whenHash CTIncome i (Right []) $ \c -> do -- whenHash CTIncome i (Right []) $ \c -> do
let meta = BudgetMeta c (NoX incCurrency) name let meta = BudgetMeta key (NoX incCurrency) name
let balRes = balanceIncome i let balRes = balanceIncome i
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
case concatEither2 balRes fromRes (,) of case concatEither2 balRes fromRes (,) of
Left es -> return $ Left es Left es -> return $ Left es
-- TODO this hole seems sloppy... -- TODO this hole seems sloppy...
Right (balance, _) -> Right (balance, _) ->
fmap (fmap (concat . concat)) $ fmap (fmap (concat . concat)) $
withDates incWhen $ \day -> do withDates incWhen $ \day -> do
let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom) let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
pre <- fromAllos incPretax pre <- fromAllos incPretax
tax <- tax <-
concatEitherL concatEitherL
<$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes
post <- fromAllos incPosttax post <- fromAllos incPosttax
let bal = let bal =
BudgetTxType BudgetTxType
{ bttTx = { bttTx =
BudgetTx BudgetTx
{ btMeta = meta { btMeta = meta
, btWhen = day , btWhen = day
, btFrom = incFrom , btFrom = incFrom
, btTo = incToBal , btTo = incToBal
, btValue = balance , btValue = balance
, btDesc = "balance after deductions" , btDesc = "balance after deductions"
} }
, bttType = FixedAmt , bttType = FixedAmt
} }
return $ concatEithersL [Right [bal], tax, Right pre, Right post] return $ concatEithersL [Right [bal], tax, Right pre, Right post]
fromAllo fromAllo
:: MonadFinance m :: MonadFinance m
@ -325,39 +329,40 @@ sumTaxes = sum . fmap (dec2Rat . taxValue)
expandTransfers expandTransfers
:: MonadFinance m :: MonadFinance m
=> T.Text => CommitRId
-> T.Text
-> [Transfer] -> [Transfer]
-> SqlPersistT m (EitherErrs [BudgetTxType]) -> SqlPersistT m (EitherErrs [BudgetTxType])
expandTransfers name ts = do expandTransfers key name ts = do
txs <- mapM (expandTransfer name) ts txs <- mapM (expandTransfer key name) ts
return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType]) expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} = expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
whenHash CTExpense t (Right []) $ \key -> -- whenHash CTExpense t (Right []) $ \key ->
fmap (fmap concat . concatEithersL) $ fmap (fmap concat . concatEithersL) $
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
withDates pat $ \day -> withDates pat $ \day ->
let meta = let meta =
BudgetMeta BudgetMeta
{ bmCur = transCurrency { bmCur = transCurrency
, bmCommit = key , bmCommit = key
, bmName = name , bmName = name
} }
tx = tx =
BudgetTxType BudgetTxType
{ bttTx = { bttTx =
BudgetTx BudgetTx
{ btMeta = meta { btMeta = meta
, btWhen = day , btWhen = day
, btFrom = transFrom , btFrom = transFrom
, btTo = transTo , btTo = transTo
, btValue = dec2Rat v , btValue = dec2Rat v
, btDesc = desc , btDesc = desc
} }
, bttType = atype , bttType = atype
} }
in return $ Right tx in return $ Right tx
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError] insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do

2
lib/Internal/Types.hs
View File

@ -524,7 +524,7 @@ data ConfigHashes = ConfigHashes
, chImport :: ![Int] , chImport :: ![Int]
} }
data ConfigType = CTIncome | CTExpense | CTShadow | CTManual | CTImport data ConfigType = CTBudget | CTManual | CTImport
deriving (Eq, Show, Read, Enum) deriving (Eq, Show, Read, Enum)
instance PersistFieldSql ConfigType where instance PersistFieldSql ConfigType where

2
lib/Internal/Utils.hs
View File

@ -350,7 +350,7 @@ showError other = (: []) $ case other of
(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 ["Could not find field", singleQuote f, "when resolving", what] T.unwords ["Could not find field", f, "when resolving", what]
where where
what = case t of what = case t of
SplitIDField st -> T.unwords ["split", idName st, "ID"] SplitIDField st -> T.unwords ["split", idName st, "ID"]