WIP unify budget and history pipelines
This commit is contained in:
parent
1ae670187a
commit
5c1d2bce9d
24
app/Main.hs
24
app/Main.hs
|
@ -174,19 +174,25 @@ runSync c = do
|
||||||
liftIOExceptT $ getDBState config
|
liftIOExceptT $ getDBState config
|
||||||
|
|
||||||
-- read desired statements from disk
|
-- read desired statements from disk
|
||||||
bSs <-
|
(rus, is) <-
|
||||||
flip runReaderT state $
|
flip runReaderT state $ do
|
||||||
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
|
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
|
-- update the DB
|
||||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||||
let runHist = do
|
res <- runExceptT $ do
|
||||||
ts <- catMaybes <$> mapErrors readHistTransfer hTs
|
-- TODO taking out the hash is dumb
|
||||||
insertHistory $ bSs ++ ts
|
(rs, ues) <- readUpdates $ fmap commitRHash rus
|
||||||
let runBudget = mapErrors insertBudget $ budget config
|
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
|
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
|
where
|
||||||
root = takeDirectory c
|
root = takeDirectory c
|
||||||
err (InsertException es) = do
|
err (InsertException es) = do
|
||||||
|
|
|
@ -1,10 +1,8 @@
|
||||||
module Internal.Budget (insertBudget) where
|
module Internal.Budget (readBudget) where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Database.Persist.Monad
|
|
||||||
import Internal.Database
|
import Internal.Database
|
||||||
import Internal.History
|
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (to)
|
import RIO hiding (to)
|
||||||
|
@ -25,11 +23,11 @@ import RIO.Time
|
||||||
-- 4. assign shadow transactions
|
-- 4. assign shadow transactions
|
||||||
-- 5. insert all transactions
|
-- 5. insert all transactions
|
||||||
|
|
||||||
insertBudget
|
readBudget
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> Budget
|
=> Budget
|
||||||
-> m ()
|
-> m (Either CommitR [Tx TxCommit])
|
||||||
insertBudget
|
readBudget
|
||||||
b@Budget
|
b@Budget
|
||||||
{ bgtLabel
|
{ bgtLabel
|
||||||
, bgtIncomes
|
, bgtIncomes
|
||||||
|
@ -40,14 +38,13 @@ insertBudget
|
||||||
, bgtPosttax
|
, bgtPosttax
|
||||||
, bgtInterval
|
, bgtInterval
|
||||||
} =
|
} =
|
||||||
whenHash CTBudget b () $ \key -> do
|
eitherHash CTBudget b return $ \key -> do
|
||||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
(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
|
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
||||||
txs <- combineError (concat <$> res1) res2 (++)
|
txs <- combineError (concat <$> res1) res2 (++)
|
||||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||||
(_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow
|
return $ txs ++ shadow
|
||||||
void $ insertBudgetTx toIns
|
|
||||||
where
|
where
|
||||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||||
|
@ -60,60 +57,6 @@ insertBudget
|
||||||
++ (alloAcnt <$> bgtTax)
|
++ (alloAcnt <$> bgtTax)
|
||||||
++ (alloAcnt <$> bgtPosttax)
|
++ (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
|
entryPair
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> TaggedAcnt
|
=> TaggedAcnt
|
||||||
|
@ -170,15 +113,15 @@ sortAllo a@Allocation {alloAmts = as} = do
|
||||||
-- TODO this will scan the interval allocations fully each time
|
-- TODO this will scan the interval allocations fully each time
|
||||||
-- iteration which is a total waste, but the fix requires turning this
|
-- iteration which is a total waste, but the fix requires turning this
|
||||||
-- loop into a fold which I don't feel like doing now :(
|
-- loop into a fold which I don't feel like doing now :(
|
||||||
insertIncome
|
readIncome
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> CommitRId
|
=> CommitR
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> IntAllocations
|
-> IntAllocations
|
||||||
-> Maybe Interval
|
-> Maybe Interval
|
||||||
-> Income
|
-> Income
|
||||||
-> m [Tx BudgetMeta]
|
-> m [Tx TxCommit]
|
||||||
insertIncome
|
readIncome
|
||||||
key
|
key
|
||||||
name
|
name
|
||||||
(intPre, intTax, intPost)
|
(intPre, intTax, intPost)
|
||||||
|
@ -212,7 +155,7 @@ insertIncome
|
||||||
dayRes = askDays incWhen localInterval
|
dayRes = askDays incWhen localInterval
|
||||||
start = fromGregorian' $ pStart incPayPeriod
|
start = fromGregorian' $ pStart incPayPeriod
|
||||||
pType' = pType incPayPeriod
|
pType' = pType incPayPeriod
|
||||||
meta = BudgetMeta key name
|
meta = BudgetCommit key name
|
||||||
flatPre = concatMap flattenAllo incPretax
|
flatPre = concatMap flattenAllo incPretax
|
||||||
flatTax = concatMap flattenAllo incTaxes
|
flatTax = concatMap flattenAllo incTaxes
|
||||||
flatPost = concatMap flattenAllo incPosttax
|
flatPost = concatMap flattenAllo incPosttax
|
||||||
|
@ -352,11 +295,11 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
||||||
|
|
||||||
allo2Trans
|
allo2Trans
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> BudgetMeta
|
=> TxCommit
|
||||||
-> Day
|
-> Day
|
||||||
-> TaggedAcnt
|
-> TaggedAcnt
|
||||||
-> FlatAllocation Rational
|
-> FlatAllocation Rational
|
||||||
-> m (Tx BudgetMeta)
|
-> m (Tx TxCommit)
|
||||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
|
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
|
||||||
-- TODO double here?
|
-- TODO double here?
|
||||||
p <- entryPair from faTo faCur faDesc (fromRational faValue)
|
p <- entryPair from faTo faCur faDesc (fromRational faValue)
|
||||||
|
@ -441,12 +384,12 @@ allocatePost precision aftertax = fmap (fmap go)
|
||||||
-- Standalone Transfer
|
-- Standalone Transfer
|
||||||
|
|
||||||
expandTransfers
|
expandTransfers
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> CommitRId
|
=> CommitR
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Maybe Interval
|
-> Maybe Interval
|
||||||
-> [BudgetTransfer]
|
-> [BudgetTransfer]
|
||||||
-> m [Tx BudgetMeta]
|
-> m [Tx TxCommit]
|
||||||
expandTransfers key name localInterval ts = do
|
expandTransfers key name localInterval ts = do
|
||||||
txs <-
|
txs <-
|
||||||
fmap (L.sortOn txDate . concat) $
|
fmap (L.sortOn txDate . concat) $
|
||||||
|
@ -459,13 +402,13 @@ expandTransfers key name localInterval ts = do
|
||||||
return $ filter (inDaySpan bounds . txDate) txs
|
return $ filter (inDaySpan bounds . txDate) txs
|
||||||
|
|
||||||
expandTransfer
|
expandTransfer
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> CommitRId
|
=> CommitR
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> BudgetTransfer
|
-> BudgetTransfer
|
||||||
-> m [Tx BudgetMeta]
|
-> m [Tx TxCommit]
|
||||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||||
fmap concat $ mapErrors go transAmounts
|
concat <$> mapErrors go transAmounts
|
||||||
where
|
where
|
||||||
go
|
go
|
||||||
Amount
|
Amount
|
||||||
|
@ -474,7 +417,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
|
||||||
, amtDesc = desc
|
, amtDesc = desc
|
||||||
} =
|
} =
|
||||||
withDates pat $ \day -> do
|
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
|
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
|
||||||
return
|
return
|
||||||
Tx
|
Tx
|
||||||
|
@ -486,7 +429,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
|
||||||
}
|
}
|
||||||
|
|
||||||
withDates
|
withDates
|
||||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
:: (MonadFinance m, MonadInsertError m)
|
||||||
=> DatePat
|
=> DatePat
|
||||||
-> (Day -> m a)
|
-> (Day -> m a)
|
||||||
-> m [a]
|
-> m [a]
|
||||||
|
@ -502,9 +445,9 @@ withDates dp f = do
|
||||||
addShadowTransfers
|
addShadowTransfers
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> [ShadowTransfer]
|
=> [ShadowTransfer]
|
||||||
-> [Tx BudgetMeta]
|
-> [Tx TxCommit]
|
||||||
-> m [Tx BudgetMeta]
|
-> m [Tx TxCommit]
|
||||||
addShadowTransfers ms txs = mapErrors go txs
|
addShadowTransfers ms = mapErrors go
|
||||||
where
|
where
|
||||||
go tx = do
|
go tx = do
|
||||||
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
||||||
|
@ -512,7 +455,7 @@ addShadowTransfers ms txs = mapErrors go txs
|
||||||
|
|
||||||
fromShadow
|
fromShadow
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> Tx BudgetMeta
|
=> Tx TxCommit
|
||||||
-> ShadowTransfer
|
-> ShadowTransfer
|
||||||
-> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
|
-> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
|
||||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
|
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
|
es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
|
||||||
return $ if not res then Nothing else Just es
|
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
|
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
|
||||||
-- NOTE this will only match against the primary entry set since those
|
-- NOTE this will only match against the primary entry set since those
|
||||||
-- are what are guaranteed to exist from a transfer
|
-- are what are guaranteed to exist from a transfer
|
||||||
|
@ -538,10 +481,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- random
|
-- random
|
||||||
|
|
||||||
-- initialCurrency :: TransferCurrency -> CurID
|
|
||||||
-- initialCurrency (NoX c) = c
|
|
||||||
-- initialCurrency (X Exchange {xFromCur = c}) = c
|
|
||||||
|
|
||||||
alloAcnt :: Allocation w v -> AcntID
|
alloAcnt :: Allocation w v -> AcntID
|
||||||
alloAcnt = taAcnt . alloTo
|
alloAcnt = taAcnt . alloTo
|
||||||
|
|
||||||
|
@ -551,85 +490,6 @@ data UnbalancedValue = UnbalancedValue
|
||||||
}
|
}
|
||||||
deriving (Show)
|
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 =
|
type IntAllocations =
|
||||||
( [DaySpanAllocation PretaxValue]
|
( [DaySpanAllocation PretaxValue]
|
||||||
, [DaySpanAllocation TaxValue]
|
, [DaySpanAllocation TaxValue]
|
||||||
|
@ -638,8 +498,6 @@ type IntAllocations =
|
||||||
|
|
||||||
type DaySpanAllocation = Allocation DaySpan
|
type DaySpanAllocation = Allocation DaySpan
|
||||||
|
|
||||||
type EntryPair = (KeyEntry, KeyEntry)
|
|
||||||
|
|
||||||
type PeriodScaler = Natural -> Double -> Double
|
type PeriodScaler = Natural -> Double -> Double
|
||||||
|
|
||||||
data FlatAllocation v = FlatAllocation
|
data FlatAllocation v = FlatAllocation
|
||||||
|
|
|
@ -459,7 +459,7 @@ resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency
|
||||||
readUpdates
|
readUpdates
|
||||||
:: (MonadInsertError m, MonadSqlQuery m)
|
:: (MonadInsertError m, MonadSqlQuery m)
|
||||||
=> [Int]
|
=> [Int]
|
||||||
-> m [Either ReadEntry UpdateEntrySet]
|
-> m ([ReadEntry], [UpdateEntrySet])
|
||||||
readUpdates hashes = do
|
readUpdates hashes = do
|
||||||
xs <- selectE $ do
|
xs <- selectE $ do
|
||||||
(commits :& txs :& entries) <-
|
(commits :& txs :& entries) <-
|
||||||
|
@ -482,7 +482,7 @@ readUpdates hashes = do
|
||||||
liftExcept $
|
liftExcept $
|
||||||
mapErrors makeUES $
|
mapErrors makeUES $
|
||||||
second (fmap snd) <$> groupWith uGroup toUpdate
|
second (fmap snd) <$> groupWith uGroup toUpdate
|
||||||
return $ fmap Left toRead ++ fmap Right toUpdate'
|
return (toRead, toUpdate')
|
||||||
where
|
where
|
||||||
unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
|
unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
|
||||||
uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
|
uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
|
||||||
|
|
|
@ -1,9 +1,10 @@
|
||||||
module Internal.History
|
module Internal.History
|
||||||
( readHistStmt
|
( readHistStmt
|
||||||
, readHistTransfer
|
, readHistTransfer
|
||||||
, insertHistory
|
, insertAll
|
||||||
, splitHistory
|
, splitHistory
|
||||||
, balanceTxs
|
, balanceTxs
|
||||||
|
, updateTx
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -26,21 +27,11 @@ import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
import qualified RIO.Vector as V
|
import qualified RIO.Vector as V
|
||||||
|
|
||||||
-- readHistory
|
-- TODO unify this with the transfer system I use in the budget now
|
||||||
-- :: (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'
|
|
||||||
|
|
||||||
readHistTransfer
|
readHistTransfer
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> HistTransfer
|
=> HistTransfer
|
||||||
-> m [Tx CommitR]
|
-> m (Either CommitR [Tx TxCommit])
|
||||||
readHistTransfer
|
readHistTransfer
|
||||||
m@Transfer
|
m@Transfer
|
||||||
{ transFrom = from
|
{ transFrom = from
|
||||||
|
@ -48,7 +39,7 @@ readHistTransfer
|
||||||
, transCurrency = u
|
, transCurrency = u
|
||||||
, transAmounts = amts
|
, transAmounts = amts
|
||||||
} =
|
} =
|
||||||
whenHash0 CTManual m [] $ \c -> do
|
eitherHash CTManual m return $ \c -> do
|
||||||
bounds <- askDBState kmStatementInterval
|
bounds <- askDBState kmStatementInterval
|
||||||
let curRes = lookupCurrency u
|
let curRes = lookupCurrency u
|
||||||
let go Amount {amtWhen, amtValue, amtDesc} = do
|
let go Amount {amtWhen, amtValue, amtDesc} = do
|
||||||
|
@ -62,11 +53,11 @@ readHistStmt
|
||||||
:: (MonadUnliftIO m, MonadFinance m)
|
:: (MonadUnliftIO m, MonadFinance m)
|
||||||
=> FilePath
|
=> FilePath
|
||||||
-> Statement
|
-> Statement
|
||||||
-> m (Either CommitR [Tx CommitR])
|
-> m (Either CommitR [Tx TxCommit])
|
||||||
readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
||||||
bs <- readImport root i
|
bs <- readImport root i
|
||||||
bounds <- askDBState kmStatementInterval
|
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 :: [History] -> ([HistTransfer], [Statement])
|
||||||
splitHistory = partitionEithers . fmap go
|
splitHistory = partitionEithers . fmap go
|
||||||
|
@ -74,17 +65,35 @@ splitHistory = partitionEithers . fmap go
|
||||||
go (HistTransfer x) = Left x
|
go (HistTransfer x) = Left x
|
||||||
go (HistStatement x) = Right x
|
go (HistStatement x) = Right x
|
||||||
|
|
||||||
insertHistory
|
insertAll
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
=> [EntryBin CommitR]
|
=> [EntryBin]
|
||||||
-> m ()
|
-> m ()
|
||||||
insertHistory hs = do
|
insertAll ebs = do
|
||||||
(toUpdate, toInsert) <- balanceTxs hs
|
(toUpdate, toInsert) <- balanceTxs ebs
|
||||||
mapM_ updateTx toUpdate
|
mapM_ updateTx toUpdate
|
||||||
forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
|
forM_ (groupWith itxCommit toInsert) $
|
||||||
\(c, ts) -> do
|
\(c, ts) -> do
|
||||||
ck <- insert c
|
ck <- insert $ getCommit c
|
||||||
mapM_ (insertTx ck) ts
|
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
|
-- low-level transaction stuff
|
||||||
|
@ -98,12 +107,12 @@ txPair
|
||||||
-> CurrencyPrec
|
-> CurrencyPrec
|
||||||
-> TransferValue
|
-> TransferValue
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Tx CommitR
|
-> Tx TxCommit
|
||||||
txPair commit day from to cur (TransferValue t v) desc =
|
txPair commit day from to cur (TransferValue t v) desc =
|
||||||
Tx
|
Tx
|
||||||
{ txDescr = desc
|
{ txDescr = desc
|
||||||
, txDate = day
|
, txDate = day
|
||||||
, txCommit = commit
|
, txCommit = HistoryCommit commit
|
||||||
, txPrimary =
|
, txPrimary =
|
||||||
EntrySet
|
EntrySet
|
||||||
{ esTotalValue = EntryValue t $ toRational v
|
{ esTotalValue = EntryValue t $ toRational v
|
||||||
|
@ -126,15 +135,6 @@ txPair commit day from to cur (TransferValue t v) desc =
|
||||||
-- resolveTx t@Tx {txEntries = ss} =
|
-- resolveTx t@Tx {txEntries = ss} =
|
||||||
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry 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
|
-- Statements
|
||||||
|
|
||||||
|
@ -349,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
|
|
||||||
balanceTxs
|
balanceTxs
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> [EntryBin a]
|
=> [EntryBin]
|
||||||
-> m ([UEBalanced], [InsertTx a])
|
-> m ([UEBalanced], [InsertTx])
|
||||||
balanceTxs ebs =
|
balanceTxs ebs =
|
||||||
first concat . partitionEithers . catMaybes
|
first concat . partitionEithers . catMaybes
|
||||||
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
|
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
|
||||||
|
@ -379,7 +379,7 @@ balanceTxs ebs =
|
||||||
Right (EntryValue t v) -> findBalance eAcnt c t v
|
Right (EntryValue t v) -> findBalance eAcnt c t v
|
||||||
Left v -> return $ toRational v * tot
|
Left v -> return $ toRational v * tot
|
||||||
|
|
||||||
binDate :: EntryBin a -> Day
|
binDate :: EntryBin -> Day
|
||||||
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
|
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
|
||||||
binDate (ToRead ReadEntry {reDate}) = reDate
|
binDate (ToRead ReadEntry {reDate}) = reDate
|
||||||
binDate (ToInsert Tx {txDate}) = txDate
|
binDate (ToInsert Tx {txDate}) = txDate
|
||||||
|
|
|
@ -20,7 +20,7 @@ share
|
||||||
CommitR sql=commits
|
CommitR sql=commits
|
||||||
hash Int
|
hash Int
|
||||||
type ConfigType
|
type ConfigType
|
||||||
deriving Show Eq
|
deriving Show Eq Ord
|
||||||
CurrencyR sql=currencies
|
CurrencyR sql=currencies
|
||||||
symbol T.Text
|
symbol T.Text
|
||||||
fullname T.Text
|
fullname T.Text
|
||||||
|
@ -67,7 +67,7 @@ BudgetLabelR sql=budget_labels
|
||||||
|]
|
|]
|
||||||
|
|
||||||
data ConfigType = CTBudget | CTManual | CTImport
|
data ConfigType = CTBudget | CTManual | CTImport
|
||||||
deriving (Eq, Show, Read, Enum)
|
deriving (Eq, Show, Read, Enum, Ord)
|
||||||
|
|
||||||
instance PersistFieldSql ConfigType where
|
instance PersistFieldSql ConfigType where
|
||||||
sqlType _ = SqlString
|
sqlType _ = SqlString
|
||||||
|
|
|
@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet
|
||||||
, utTotalValue :: !Rational
|
, utTotalValue :: !Rational
|
||||||
}
|
}
|
||||||
|
|
||||||
data EntryBin a
|
data EntryBin
|
||||||
= ToUpdate UpdateEntrySet
|
= ToUpdate UpdateEntrySet
|
||||||
| ToRead ReadEntry
|
| ToRead ReadEntry
|
||||||
| ToInsert (Tx a)
|
| ToInsert (Tx TxCommit)
|
||||||
|
|
||||||
data InsertEntry a c t = InsertEntry
|
data InsertEntry a c t = InsertEntry
|
||||||
{ feCurrency :: !c
|
{ feCurrency :: !c
|
||||||
|
@ -218,6 +218,8 @@ data EntrySet a c t v v' = EntrySet
|
||||||
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
|
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord)
|
||||||
|
|
||||||
data Tx k = Tx
|
data Tx k = Tx
|
||||||
{ txDescr :: !T.Text
|
{ txDescr :: !T.Text
|
||||||
, txDate :: !Day
|
, txDate :: !Day
|
||||||
|
@ -227,11 +229,11 @@ data Tx k = Tx
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
data InsertTx a = InsertTx
|
data InsertTx = InsertTx
|
||||||
{ itxDescr :: !T.Text
|
{ itxDescr :: !T.Text
|
||||||
, itxDate :: !Day
|
, itxDate :: !Day
|
||||||
, itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
|
, itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
|
||||||
, itxCommit :: !a
|
, itxCommit :: !TxCommit
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue