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

ENH ensure tx sort order is (kinda) stable

This commit is contained in:
Nathan Dwarshuis 2023-07-21 19:57:54 -04:00
parent bd94afd30f
commit e9772e6516
6 changed files with 97 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
lib/Internal/Budget.hs
View File

@ -153,13 +153,9 @@ readIncome
}
return $
Tx
{ txCommit = key
, txDate = day
{ txMeta = TxMeta day incPriority (TxDesc "") key
, txPrimary = Left primary
, txOther = []
, txDesc = TxDesc ""
, -- , txBudget = name
txPriority = incPriority
}
periodScaler
@ -358,25 +354,28 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
shaRes = liftExcept $ shadowMatches stMatch tx
shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} 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
valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True
return $
memberMaybe fa tmFrom
&& memberMaybe ta tmTo
&& maybe True (`dateMatches` txDate) tmDate
&& valRes
where
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` (AcntID <$> asList)
shadowMatches
TransferMatcher {tmFrom, tmTo, tmDate, tmVal}
Tx {txPrimary, txMeta = TxMeta {txmDate}} =
do
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True
return $
memberMaybe fa tmFrom
&& memberMaybe ta tmTo
&& maybe True (`dateMatches` txmDate) tmDate
&& valRes
where
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` (AcntID <$> asList)
--------------------------------------------------------------------------------
-- random

37
lib/Internal/Database.hs
View File

@ -469,6 +469,7 @@ updateCD (CRUDOps cs () () ds) = do
mapM_ deleteKeyE ds
insertEntityManyE cs
-- TODO defer foreign keys so I don't need to confusingly reverse this stuff
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do
mapM_ deleteKeyE dtTagRelations
@ -566,8 +567,10 @@ readUpdates hashes = do
,
(
( entrysets ^. EntrySetRId
, entrysets ^. EntrySetRIndex
, txs ^. TransactionRDate
, txs ^. TransactionRPriority
, txs ^. TransactionRDescription
,
( entrysets ^. EntrySetRCurrency
, currencies ^. CurrencyRPrecision
@ -577,11 +580,12 @@ readUpdates hashes = do
)
)
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _) -> i) (snd <$> toUpdate)
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _, _) -> i) (snd <$> toUpdate)
let toRead' = fmap (makeRE . snd) toRead
return (toRead', toUpdate')
where
makeUES ((_, day, pri, (curID, prec)), es) = do
makeUES ((_, esi, day, pri, desc, (curID, prec)), es) = do
let sk = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
let prec' = fromIntegral $ E.unValue prec
let cur = E.unValue curID
let res =
@ -599,8 +603,7 @@ readUpdates hashes = do
Left x ->
Left $
UpdateEntrySet
{ utDate = E.unValue day
, utCurrency = cur
{ utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
@ -608,13 +611,13 @@ readUpdates hashes = do
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = realFracToDecimalP prec' tot
, utPriority = E.unValue pri
, utSortKey = sk
, utIndex = E.unValue esi
}
Right x ->
Right $
UpdateEntrySet
{ utDate = E.unValue day
, utCurrency = cur
{ utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
@ -622,18 +625,20 @@ readUpdates hashes = do
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = ()
, utPriority = E.unValue pri
, utSortKey = sk
, utIndex = E.unValue esi
}
-- TODO this error is lame
_ -> throwAppError $ DBError DBUpdateUnbalanced
makeRE ((_, day, pri, (curID, prec)), entry) = do
makeRE ((_, esi, day, pri, desc, (curID, prec)), entry) = do
let e = entityVal entry
in ReadEntry
{ reDate = E.unValue day
, reCurrency = E.unValue curID
{ reCurrency = E.unValue curID
, reAcnt = entryRAccount e
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
, rePriority = E.unValue pri
, reSortKey = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
, reESIndex = E.unValue esi
, reIndex = entryRIndex e
}
splitFrom
@ -792,7 +797,7 @@ insertBudgets (CRUDOps bs () () ds) = do
-- TODO useless overhead?
(toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
mapM_ updateTx toUpdate
forM_ (groupWith itxCommit toInsert) $
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
\(c, ts) -> do
ck <- insert c
mapM_ (insertTx name ck) ts
@ -804,7 +809,7 @@ insertHistory
insertHistory (CRUDOps cs rs us ds) = do
(toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
mapM_ updateTx toUpdate
forM_ (groupWith itxCommit toInsert) $
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
\(c, ts) -> do
ck <- insert c
mapM_ (insertTx historyName ck) ts
@ -829,8 +834,8 @@ insertHistory (CRUDOps cs rs us ds) = do
-- deleteTxs ds
insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
insertTx b c InsertTx {itxDate, itxDesc, itxEntrySets, itxPriority} = do
k <- insert $ TransactionR c itxDate b itxDesc itxPriority
insertTx b c InsertTx {itxMeta = TxMeta {txmDate, txmPriority, txmDesc}, itxEntrySets} = do
k <- insert $ TransactionR c txmDate b txmDesc txmPriority
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
where
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do

10
lib/Internal/History.hs
View File

@ -72,9 +72,10 @@ readHistStmt
readHistStmt root i = do
bounds <- asks (unHSpan . tsHistoryScope)
bs <- readImport root i
return $ filter (inDaySpan bounds . txDate) . fmap (\t -> t {txCommit = c}) <$> bs
return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
where
c = CommitR (CommitHash $ hash i) CTHistoryStatement
go t@Tx {txMeta = m} =
t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
-- TODO this probably won't scale well (pipes?)
readImport
@ -319,9 +320,7 @@ toTx
r@TxRecord {trAmount, trDate, trDesc} = do
combineError curRes subRes $ \(cur, f, t) ss ->
Tx
{ txDate = trDate
, txDesc = trDesc
, txCommit = ()
{ txMeta = TxMeta trDate priority trDesc ()
, txPrimary =
Left $
EntrySet
@ -331,7 +330,6 @@ toTx
, esTo = t
}
, txOther = Left <$> ss
, txPriority = priority
}
where
curRes = do

12
lib/Internal/Types/Database.hs
View File

@ -24,10 +24,12 @@ CommitR sql=commits
type ConfigType
UniqueCommitHash hash
deriving Show Eq Ord
ConfigStateR sql=config_state
historySpan HistorySpan
budgetSpan BudgetSpan
deriving Show
CurrencyR sql=currencies
symbol CurID
fullname T.Text
@ -35,12 +37,14 @@ CurrencyR sql=currencies
UniqueCurrencySymbol symbol
UniqueCurrencyFullname fullname
deriving Show Eq Ord
TagR sql=tags
symbol TagID
fullname T.Text
UniqueTagSymbol symbol
UniqueTagFullname fullname
deriving Show Eq Ord
AccountR sql=accounts
name T.Text
fullpath AcntPath
@ -49,11 +53,13 @@ AccountR sql=accounts
leaf Bool
UniqueAccountFullpath fullpath
deriving Show Eq Ord
AccountPathR sql=account_paths
parent AccountRId
child AccountRId
depth Int
deriving Show Eq Ord
TransactionR sql=transactions
commit CommitRId
date Day
@ -61,12 +67,14 @@ TransactionR sql=transactions
description TxDesc
priority Int
deriving Show Eq
EntrySetR sql=entry_sets
transaction TransactionRId
currency CurrencyRId
index EntrySetIndex
rebalance Bool
deriving Show Eq
EntryR sql=entries
entryset EntrySetRId
account AccountRId
@ -77,12 +85,16 @@ EntryR sql=entries
cachedType (Maybe TransferType)
cachedLink (Maybe EntryIndex)
deriving Show Eq
TagRelationR sql=tag_relations
entry EntryRId
tag TagRId
deriving Show Eq
|]
newtype TxIndex = TxIndex {unTxIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)

34
lib/Internal/Types/Main.hs
View File

@ -102,14 +102,22 @@ data CachedEntry
| CachedBalance Decimal
| CachedPercent Double
data TxSortKey = TxSortKey
{ tskDate :: !Day
, tskPriority :: !Int
, tskDesc :: !TxDesc
}
deriving (Show, Eq, Ord)
-- TODO this should actually be a ReadTx since it will be compared with other
-- Tx's to get the insert/update order correct
data ReadEntry = ReadEntry
{ reCurrency :: !CurrencyRId
, reAcnt :: !AccountRId
, reValue :: !Decimal
, reDate :: !Day
, rePriority :: !Int
, reIndex :: !EntryIndex
, reESIndex :: !EntrySetIndex
, reSortKey :: !TxSortKey
}
deriving (Show)
@ -149,9 +157,9 @@ data UpdateEntrySet f t = UpdateEntrySet
, utFromRO :: ![UE_RO]
, utToRO :: ![UE_RO]
, utCurrency :: !CurrencyRId
, utDate :: !Day
, utTotalValue :: !t
, utPriority :: !Int
, utIndex :: !EntrySetIndex
, utSortKey :: !TxSortKey
}
deriving (Show)
@ -214,13 +222,18 @@ type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
deriving (Eq, Ord, Show)
data TxMeta k = TxMeta
{ txmDate :: !Day
, txmPriority :: !Int
, txmDesc :: !TxDesc
, txmCommit :: !k
}
deriving (Show, Eq, Ord)
data Tx k = Tx
{ txDesc :: !TxDesc
, txDate :: !Day
, txPriority :: !Int
{ txMeta :: !(TxMeta k)
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
, txCommit :: !k
}
deriving (Generic, Show)
@ -236,11 +249,8 @@ data InsertEntrySet = InsertEntrySet
}
data InsertTx = InsertTx
{ itxDesc :: !TxDesc
, itxDate :: !Day
, itxPriority :: !Int
{ itxMeta :: !(TxMeta CommitR)
, itxEntrySets :: !(NonEmpty InsertEntrySet)
, itxCommit :: !CommitR
}
deriving (Generic)

33
lib/Internal/Utils.hs
View File

@ -642,19 +642,11 @@ balanceTxs ebs =
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
modify $ mapAdd_ (reAcnt, reCurrency) reValue
return Nothing
go (ToInsert Tx {txPrimary, txOther, txDesc, txCommit, txDate, txPriority}) = do
go (ToInsert Tx {txPrimary, txOther, txMeta}) = do
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
es <- mapErrors (goOther tot) txOther
let tx =
-- TODO this is lame
InsertTx
{ itxDesc = txDesc
, itxDate = txDate
, itxEntrySets = e :| es
, itxCommit = txCommit
, itxPriority = txPriority
}
let tx = InsertTx {itxMeta = txMeta, itxEntrySets = e :| es}
return $ Just $ Right tx
where
goOther tot =
@ -663,12 +655,20 @@ balanceTxs ebs =
(balancePrimaryEntrySet . fromShadow tot)
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
binDate :: EntryCRU -> (Day, Int)
binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
-- NOTE this sorting thing is super wonky; I'm basically sorting three different
-- levels of the hierarchy directory and assuming there will be no overlaps.
-- First, sort at the transaction level by day, priority, and description as
-- tiebreaker. Anything that shares those three keys will have an unstable sort
-- order. Within the entrysets, use the index as it appears in the
-- configuration, and same with the entries. Since we assume no overlap, nothing
-- "bad" should happen if the levels above entries/entrysets sort on 'Nothing'
-- for the indices they don't have at their level.
binDate :: EntryCRU -> (TxSortKey, Maybe EntrySetIndex, Maybe EntryIndex)
binDate (ToRead ReadEntry {reSortKey, reESIndex, reIndex}) = (reSortKey, Just reESIndex, Just reIndex)
binDate (ToInsert Tx {txMeta = (TxMeta t p d _)}) = (TxSortKey t p d, Nothing, Nothing)
binDate (ToUpdate u) = either go go u
where
go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
go UpdateEntrySet {utSortKey, utIndex} = (utSortKey, Just utIndex, Nothing)
type BCKey = CurrencyRId
@ -988,12 +988,9 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
withDates bounds pat $ \day ->
return
Tx
{ txCommit = tc
, txDate = day
{ txMeta = TxMeta day (fromIntegral pri) (TxDesc desc) tc
, txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
, txOther = []
, txDesc = TxDesc desc
, txPriority = fromIntegral pri
}
entryPair