From e9772e6516ce1bfe80ddd2410337caee585f2fcb Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 21 Jul 2023 19:57:54 -0400 Subject: [PATCH] ENH ensure tx sort order is (kinda) stable --- lib/Internal/Budget.hs | 47 +++++++++++++++++----------------- lib/Internal/Database.hs | 37 ++++++++++++++------------ lib/Internal/History.hs | 10 +++----- lib/Internal/Types/Database.hs | 12 +++++++++ lib/Internal/Types/Main.hs | 34 +++++++++++++++--------- lib/Internal/Utils.hs | 33 +++++++++++------------- 6 files changed, 97 insertions(+), 76 deletions(-) diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index c46636d..1411c65 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -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 diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 78972a6..3927b76 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -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 diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index aefdb08..cf51b8b 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -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 diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index e7509f6..4ca9264 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -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) diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index f56f67a..cd49a21 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -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) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index dcaffe8..25633a3 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -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