WIP unify budget and history pipelines

This commit is contained in:
Nathan Dwarshuis 2023-07-01 13:12:50 -04:00
parent 1ae670187a
commit 5c1d2bce9d
6 changed files with 91 additions and 225 deletions

View File

@ -174,19 +174,25 @@ runSync c = do
liftIOExceptT $ getDBState config
-- read desired statements from disk
bSs <-
flip runReaderT state $
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
(rus, is) <-
flip runReaderT state $ do
hSs' <- mapErrorsIO (readHistStmt root) hSs
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
-- update the DB
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
let runHist = do
ts <- catMaybes <$> mapErrors readHistTransfer hTs
insertHistory $ bSs ++ ts
let runBudget = mapErrors insertBudget $ budget config
res <- runExceptT $ do
-- TODO taking out the hash is dumb
(rs, ues) <- readUpdates $ fmap commitRHash rus
let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
insertAll ebs
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
-- whatever error is encountered above in an IO context, but the first
-- thrown error should be caught despite possibly needing to be rerun
rerunnableIO $ fromEither res
updateDBState updates -- TODO this will only work if foreign keys are deferred
res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
rerunnableIO $ fromEither res -- TODO why is this here?
where
root = takeDirectory c
err (InsertException es) = do

View File

@ -1,10 +1,8 @@
module Internal.Budget (insertBudget) where
module Internal.Budget (readBudget) where
import Control.Monad.Except
import Data.Foldable
import Database.Persist.Monad
import Internal.Database
import Internal.History
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
@ -25,11 +23,11 @@ import RIO.Time
-- 4. assign shadow transactions
-- 5. insert all transactions
insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
readBudget
:: (MonadInsertError m, MonadFinance m)
=> Budget
-> m ()
insertBudget
-> m (Either CommitR [Tx TxCommit])
readBudget
b@Budget
{ bgtLabel
, bgtIncomes
@ -40,14 +38,13 @@ insertBudget
, bgtPosttax
, bgtInterval
} =
whenHash CTBudget b () $ \key -> do
eitherHash CTBudget b return $ \key -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
shadow <- addShadowTransfers bgtShadowTransfers txs
(_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow
void $ insertBudgetTx toIns
return $ txs ++ shadow
where
acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,)
@ -60,60 +57,6 @@ insertBudget
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
-- TODO need to systematically make this function match the history version,
-- which will allow me to use the same balancing algorithm for both
-- balanceTransfers :: [Tx BudgetMeta] -> [KeyEntry]
-- balanceTransfers = undefined
-- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
-- where
-- go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
-- let balTo = M.findWithDefault 0 ftTo bals
-- x = amtToMove balTo cvType cvValue
-- bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
-- in (bals', f {ftValue = x})
-- -- TODO might need to query signs to make this intuitive; as it is this will
-- -- probably work, but for credit accounts I might need to supply a negative
-- -- target value
-- amtToMove _ TFixed x = x
-- amtToMove bal TPercent x = -(x / 100 * bal)
-- amtToMove bal TBalance x = x - bal
insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [InsertTx BudgetMeta]
-> m ()
insertBudgetTx toInsert = do
forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $
\(c, ts) -> do
ck <- insert $ bmCommit c
mapM_ (insertTx ck) ts
where
insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do
let anyDeferred = any (isJust . feDeferred) ss
k <- insert $ TransactionR c d e anyDeferred
mapM_ (insertBudgetLabel bmName k) ss
insertBudgetLabel n k entry = do
sk <- insertEntry k entry
insert_ $ BudgetLabelR sk n
-- insertBudgetTx
-- :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-- => BalancedTransfer
-- -> m ()
-- insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
-- ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
-- insertPair sFrom sTo
-- forM_ exchange $ uncurry insertPair
-- where
-- insertPair from to = do
-- k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
-- insertBudgetLabel k from
-- insertBudgetLabel k to
-- insertBudgetLabel k entry = do
-- sk <- insertEntry k entry
-- insert_ $ BudgetLabelR sk $ bmName ftMeta
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
@ -170,15 +113,15 @@ sortAllo a@Allocation {alloAmts = as} = do
-- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :(
insertIncome
readIncome
:: (MonadInsertError m, MonadFinance m)
=> CommitRId
=> CommitR
-> T.Text
-> IntAllocations
-> Maybe Interval
-> Income
-> m [Tx BudgetMeta]
insertIncome
-> m [Tx TxCommit]
readIncome
key
name
(intPre, intTax, intPost)
@ -212,7 +155,7 @@ insertIncome
dayRes = askDays incWhen localInterval
start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod
meta = BudgetMeta key name
meta = BudgetCommit key name
flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax
@ -352,11 +295,11 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
allo2Trans
:: (MonadInsertError m, MonadFinance m)
=> BudgetMeta
=> TxCommit
-> Day
-> TaggedAcnt
-> FlatAllocation Rational
-> m (Tx BudgetMeta)
-> m (Tx TxCommit)
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
-- TODO double here?
p <- entryPair from faTo faCur faDesc (fromRational faValue)
@ -441,12 +384,12 @@ allocatePost precision aftertax = fmap (fmap go)
-- Standalone Transfer
expandTransfers
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
:: (MonadInsertError m, MonadFinance m)
=> CommitR
-> T.Text
-> Maybe Interval
-> [BudgetTransfer]
-> m [Tx BudgetMeta]
-> m [Tx TxCommit]
expandTransfers key name localInterval ts = do
txs <-
fmap (L.sortOn txDate . concat) $
@ -459,13 +402,13 @@ expandTransfers key name localInterval ts = do
return $ filter (inDaySpan bounds . txDate) txs
expandTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
:: (MonadInsertError m, MonadFinance m)
=> CommitR
-> T.Text
-> BudgetTransfer
-> m [Tx BudgetMeta]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
fmap concat $ mapErrors go transAmounts
-> m [Tx TxCommit]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
concat <$> mapErrors go transAmounts
where
go
Amount
@ -474,7 +417,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
, amtDesc = desc
} =
withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name}
let meta = BudgetCommit key name
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
return
Tx
@ -486,7 +429,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
}
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
:: (MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
@ -502,9 +445,9 @@ withDates dp f = do
addShadowTransfers
:: (MonadInsertError m, MonadFinance m)
=> [ShadowTransfer]
-> [Tx BudgetMeta]
-> m [Tx BudgetMeta]
addShadowTransfers ms txs = mapErrors go txs
-> [Tx TxCommit]
-> m [Tx TxCommit]
addShadowTransfers ms = mapErrors go
where
go tx = do
es <- catMaybes <$> mapErrors (fromShadow tx) ms
@ -512,7 +455,7 @@ addShadowTransfers ms txs = mapErrors go txs
fromShadow
:: (MonadInsertError m, MonadFinance m)
=> Tx BudgetMeta
=> Tx TxCommit
-> ShadowTransfer
-> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
@ -520,7 +463,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
return $ if not res then Nothing else Just es
shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool
shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
@ -538,10 +481,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
--------------------------------------------------------------------------------
-- random
-- initialCurrency :: TransferCurrency -> CurID
-- initialCurrency (NoX c) = c
-- initialCurrency (X Exchange {xFromCur = c}) = c
alloAcnt :: Allocation w v -> AcntID
alloAcnt = taAcnt . alloTo
@ -551,85 +490,6 @@ data UnbalancedValue = UnbalancedValue
}
deriving (Show)
-- TODO need to make this into the same ish thing as the Tx/EntrySet structs
-- in the history algorithm, which will entail resolving the budget currency
-- stuff earlier in the chain, and preloading multiple entries into this thing
-- before balancing.
-- type UnbalancedTransfer = FlatTransfer UnbalancedValue
-- ubt2tx :: UnbalancedTransfer -> Tx BudgetMeta
-- ubt2tx
-- FlatTransfer
-- { ftFrom
-- , ftTo
-- , ftValue
-- , ftWhen
-- , ftDesc
-- , ftMeta
-- , ftCur
-- } =
-- Tx
-- { txDescr = ftDesc
-- , txDate = ftWhen
-- , txPrimary = p
-- , txOther = maybeToList os
-- , txCommit = ftMeta
-- }
-- where
-- (p, os) = entries ftCur
-- entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing)
-- entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
-- let middle = TaggedAcnt xAcnt []
-- p1 = pair xFromCur ftFrom middle ftValue
-- p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
-- in (p1, Just p2)
-- pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
-- EntrySet
-- { esTotalValue = v
-- , esCurrency = c
-- , esFrom =
-- HalfEntrySet
-- { hesPrimary =
-- Entry
-- { eValue = ()
-- , eComment = ""
-- , eAcnt = fa
-- , eTags = fts
-- }
-- , hesOther = []
-- }
-- , esTo =
-- HalfEntrySet
-- { hesPrimary =
-- Entry
-- { eValue = ()
-- , eComment = ""
-- , eAcnt = ta
-- , eTags = tts
-- }
-- , hesOther = []
-- }
-- }
-- type BalancedTransfer = FlatTransfer Rational
-- data FlatTransfer v = FlatTransfer
-- { ftFrom :: !TaggedAcnt
-- , ftTo :: !TaggedAcnt
-- , ftValue :: !v
-- , ftWhen :: !Day
-- , ftDesc :: !T.Text
-- , ftMeta :: !BudgetMeta
-- , ftCur :: !TransferCurrency
-- }
-- deriving (Show)
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitR
, bmName :: !T.Text
}
deriving (Show)
type IntAllocations =
( [DaySpanAllocation PretaxValue]
, [DaySpanAllocation TaxValue]
@ -638,8 +498,6 @@ type IntAllocations =
type DaySpanAllocation = Allocation DaySpan
type EntryPair = (KeyEntry, KeyEntry)
type PeriodScaler = Natural -> Double -> Double
data FlatAllocation v = FlatAllocation

View File

@ -459,7 +459,7 @@ resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency
readUpdates
:: (MonadInsertError m, MonadSqlQuery m)
=> [Int]
-> m [Either ReadEntry UpdateEntrySet]
-> m ([ReadEntry], [UpdateEntrySet])
readUpdates hashes = do
xs <- selectE $ do
(commits :& txs :& entries) <-
@ -482,7 +482,7 @@ readUpdates hashes = do
liftExcept $
mapErrors makeUES $
second (fmap snd) <$> groupWith uGroup toUpdate
return $ fmap Left toRead ++ fmap Right toUpdate'
return (toRead, toUpdate')
where
unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)

View File

@ -1,9 +1,10 @@
module Internal.History
( readHistStmt
, readHistTransfer
, insertHistory
, insertAll
, splitHistory
, balanceTxs
, updateTx
)
where
@ -26,21 +27,11 @@ import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
-- readHistory
-- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
-- => FilePath
-- -> [History]
-- -> m [(CommitR, [DeferredTx])]
-- readHistory root hs = do
-- let (ts, ss) = splitHistory hs
-- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
-- ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
-- return $ ts' ++ ss'
-- TODO unify this with the transfer system I use in the budget now
readHistTransfer
:: (MonadInsertError m, MonadFinance m)
=> HistTransfer
-> m [Tx CommitR]
-> m (Either CommitR [Tx TxCommit])
readHistTransfer
m@Transfer
{ transFrom = from
@ -48,7 +39,7 @@ readHistTransfer
, transCurrency = u
, transAmounts = amts
} =
whenHash0 CTManual m [] $ \c -> do
eitherHash CTManual m return $ \c -> do
bounds <- askDBState kmStatementInterval
let curRes = lookupCurrency u
let go Amount {amtWhen, amtValue, amtDesc} = do
@ -62,11 +53,11 @@ readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Either CommitR [Tx CommitR])
-> m (Either CommitR [Tx TxCommit])
readHistStmt root i = eitherHash CTImport i return $ \c -> do
bs <- readImport root i
bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
@ -74,17 +65,35 @@ splitHistory = partitionEithers . fmap go
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
insertHistory
insertAll
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [EntryBin CommitR]
=> [EntryBin]
-> m ()
insertHistory hs = do
(toUpdate, toInsert) <- balanceTxs hs
insertAll ebs = do
(toUpdate, toInsert) <- balanceTxs ebs
mapM_ updateTx toUpdate
forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
forM_ (groupWith itxCommit toInsert) $
\(c, ts) -> do
ck <- insert c
ck <- insert $ getCommit c
mapM_ (insertTx ck) ts
where
getCommit (HistoryCommit c) = c
getCommit (BudgetCommit c _) = c
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
let anyDeferred = any (isJust . feDeferred) itxEntries
k <- insert $ TransactionR c itxDate itxDescr anyDeferred
mapM_ (go k) itxEntries
where
go k tx = do
ek <- insertEntry k tx
case itxCommit of
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
_ -> return ()
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
--------------------------------------------------------------------------------
-- low-level transaction stuff
@ -98,12 +107,12 @@ txPair
-> CurrencyPrec
-> TransferValue
-> T.Text
-> Tx CommitR
-> Tx TxCommit
txPair commit day from to cur (TransferValue t v) desc =
Tx
{ txDescr = desc
, txDate = day
, txCommit = commit
, txCommit = HistoryCommit commit
, txPrimary =
EntrySet
{ esTotalValue = EntryValue t $ toRational v
@ -126,15 +135,6 @@ txPair commit day from to cur (TransferValue t v) desc =
-- resolveTx t@Tx {txEntries = ss} =
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx CommitR -> m ()
insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
let anyDeferred = any (isJust . feDeferred) ss
k <- insert $ TransactionR c d e anyDeferred
mapM_ (insertEntry k) ss
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
--------------------------------------------------------------------------------
-- Statements
@ -349,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms)
balanceTxs
:: (MonadInsertError m, MonadFinance m)
=> [EntryBin a]
-> m ([UEBalanced], [InsertTx a])
=> [EntryBin]
-> m ([UEBalanced], [InsertTx])
balanceTxs ebs =
first concat . partitionEithers . catMaybes
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
@ -379,7 +379,7 @@ balanceTxs ebs =
Right (EntryValue t v) -> findBalance eAcnt c t v
Left v -> return $ toRational v * tot
binDate :: EntryBin a -> Day
binDate :: EntryBin -> Day
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
binDate (ToRead ReadEntry {reDate}) = reDate
binDate (ToInsert Tx {txDate}) = txDate

View File

@ -20,7 +20,7 @@ share
CommitR sql=commits
hash Int
type ConfigType
deriving Show Eq
deriving Show Eq Ord
CurrencyR sql=currencies
symbol T.Text
fullname T.Text
@ -67,7 +67,7 @@ BudgetLabelR sql=budget_labels
|]
data ConfigType = CTBudget | CTManual | CTImport
deriving (Eq, Show, Read, Enum)
deriving (Eq, Show, Read, Enum, Ord)
instance PersistFieldSql ConfigType where
sqlType _ = SqlString

View File

@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet
, utTotalValue :: !Rational
}
data EntryBin a
data EntryBin
= ToUpdate UpdateEntrySet
| ToRead ReadEntry
| ToInsert (Tx a)
| ToInsert (Tx TxCommit)
data InsertEntry a c t = InsertEntry
{ feCurrency :: !c
@ -218,6 +218,8 @@ data EntrySet a c t v v' = EntrySet
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
}
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord)
data Tx k = Tx
{ txDescr :: !T.Text
, txDate :: !Day
@ -227,11 +229,11 @@ data Tx k = Tx
}
deriving (Generic)
data InsertTx a = InsertTx
data InsertTx = InsertTx
{ itxDescr :: !T.Text
, itxDate :: !Day
, itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
, itxCommit :: !a
, itxCommit :: !TxCommit
}
deriving (Generic)