From 8901fd6a64ee58da67e88a40322982a492bd0633 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 15 Jul 2023 23:25:28 -0400 Subject: [PATCH] FIX update bugs --- app/Main.hs | 24 +++-- lib/Internal/Budget.hs | 2 +- lib/Internal/Database.hs | 166 ++++++++++++++++----------------- lib/Internal/History.hs | 8 +- lib/Internal/Types/Database.hs | 47 ++++++---- lib/Internal/Types/Main.hs | 15 +-- lib/Internal/Utils.hs | 2 +- 7 files changed, 144 insertions(+), 120 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 1af3fc0..4304bc0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,6 +8,7 @@ import Control.Monad.IO.Rerunnable import Control.Monad.Logger import Control.Monad.Reader import Data.Bitraversable +-- import Data.Hashable import qualified Data.Text.IO as TI import qualified Database.Esqueleto.Experimental as E import Database.Persist.Monad @@ -20,7 +21,7 @@ import Internal.Utils import Options.Applicative import RIO import RIO.FilePath -import qualified RIO.Map as M +-- import qualified RIO.Map as M import qualified RIO.Text as T main :: IO () @@ -233,7 +234,7 @@ runSync threads c bs hs = do -- TODO for some mysterious reason using multithreading just for this -- little bit slows the program down by several seconds -- lift $ setNumCapabilities threads - (liftIO . print) =<< askDBState (M.keys . csAccountMap) + -- (liftIO . print) =<< askDBState (M.keys . csAccountMap) -- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts) (CRUDOps hSs _ _ _) <- askDBState csHistStmts hSs' <- mapErrorsIO (readHistStmt root) hSs @@ -247,12 +248,19 @@ runSync threads c bs hs = do bTs' <- liftIOExceptT $ mapErrors readBudget bTs -- lift $ print $ length $ lefts bTs return $ concat $ hSs' ++ hTs' ++ bTs' - -- print $ length $ kmNewCommits state - -- print $ length $ duOldCommits updates - -- print $ length $ duNewTagIds updates - -- print $ length $ duNewAcntPaths updates - -- print $ length $ duNewAcntIds updates - -- print $ length $ duNewCurrencyIds updates + print $ length $ coCreate $ csBudgets state + print $ length $ coCreate $ csHistTrans state + print $ length $ coCreate $ csHistStmts state + print $ length $ coUpdate $ csBudgets state + print $ length $ coUpdate $ csHistTrans state + print $ length $ coUpdate $ csHistStmts state + print $ length $ coRead $ csBudgets state + print $ length $ coRead $ csHistTrans state + print $ length $ coRead $ csHistStmts state + print $ coDelete $ csBudgets state + print $ coDelete $ csHistTrans state + print $ coDelete $ csHistStmts state + -- print $ fmap hash $ coCreate $ csHistStmts state -- Update the DB. runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 251701e..feeb26c 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -49,7 +49,7 @@ readBudget ++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtPosttax) getSpan = do - globalSpan <- askDBState csBudgetScope + globalSpan <- askDBState (unBSpan . csBudgetScope) case bgtInterval of Nothing -> return $ Just globalSpan Just bi -> do diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 8fb0523..507e09c 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -22,7 +22,7 @@ import Control.Monad.Except import Control.Monad.Logger import Data.Decimal import Data.Hashable -import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.)) +import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.)) import qualified Database.Esqueleto.Experimental as E import Database.Esqueleto.Internal.Internal (SqlSelect) import Database.Persist.Monad @@ -42,11 +42,10 @@ import GHC.Err import Internal.Types.Main import Internal.Utils import RIO hiding (LogFunc, isNothing, on, (^.)) -import qualified RIO.HashSet as HS import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.NonEmpty as NE --- import qualified RIO.Set as S +import qualified RIO.Set as S import qualified RIO.Text as T runDB @@ -126,67 +125,66 @@ readConfigState -> [History] -> m ConfigState readConfigState c bs hs = do - curAcnts <- readCurrentIds AccountRId - curTags <- readCurrentIds TagRId - curCurs <- readCurrentIds CurrencyRId - curPaths <- readCurrentIds AccountPathRId - let (acnts2Ins, acntsRem, acnts2Del) = diff newAcnts curAcnts - let (pathsIns, _, pathsDel) = diff newPaths curPaths - let (curs2Ins, cursRem, curs2Del) = diff newCurs curCurs - let (tags2Ins, tagsRem, tags2Del) = diff newTags curTags + (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts + (pathsIns, _, pathsDel) <- diff newPaths + (curs2Ins, cursRem, curs2Del) <- diff newCurs + (tags2Ins, tagsRem, tags2Del) <- diff newTags let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem) let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem) let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem) - let fromMap f = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems + let fromMap f = S.fromList . fmap f . M.elems let existing = ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap) (curBgts, curHistTrs, curHistSts) <- readCurrentCommits - (bChanged, hChanged) <- readScopeChanged $ scope c - bgt <- makeTxCRUD existing bs curBgts bChanged - hTrans <- makeTxCRUD existing ts curHistTrs hChanged - hStmt <- makeTxCRUD existing ss curHistSts hChanged + -- TODO refine this test to include the whole db (with data already mixed + -- in this algorithm) + let bsRes = BudgetSpan <$> resolveScope budgetInterval + let hsRes = HistorySpan <$> resolveScope statementInterval + combineErrorM bsRes hsRes $ \bscope hscope -> do + let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts + (bChanged, hChanged) <- readScopeChanged dbempty bscope hscope + bgt <- makeTxCRUD existing bs curBgts bChanged + hTrans <- makeTxCRUD existing ts curHistTrs hChanged + hStmt <- makeTxCRUD existing ss curHistSts hChanged - let bsRes = resolveScope budgetInterval - let hsRes = resolveScope statementInterval - combineError bsRes hsRes $ \b h -> - ConfigState - { csCurrencies = CRUDOps curs2Ins () () curs2Del - , csTags = CRUDOps tags2Ins () () tags2Del - , csAccounts = CRUDOps acnts2Ins () () acnts2Del - , csPaths = CRUDOps pathsIns () () pathsDel - , csBudgets = bgt - , csHistTrans = hTrans - , csHistStmts = hStmt - , csAccountMap = amap - , csCurrencyMap = cmap - , csTagMap = tmap - , csBudgetScope = b - , csHistoryScope = h - } + return $ + ConfigState + { csCurrencies = CRUDOps curs2Ins () () curs2Del + , csTags = CRUDOps tags2Ins () () tags2Del + , csAccounts = CRUDOps acnts2Ins () () acnts2Del + , csPaths = CRUDOps pathsIns () () pathsDel + , csBudgets = bgt + , csHistTrans = hTrans + , csHistStmts = hStmt + , csAccountMap = amap + , csCurrencyMap = cmap + , csTagMap = tmap + , csBudgetScope = bscope + , csHistoryScope = hscope + } where (ts, ss) = splitHistory hs - diff :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a]) - diff = setDiffWith (\a b -> E.entityKey a == b) + diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds (newAcnts, newPaths) = indexAcntRoot $ accounts c newTags = tag2Record <$> tags c newCurs = currency2Record <$> currencies c resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c -readScopeChanged :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool) -readScopeChanged s = do +readScopeChanged + :: (MonadInsertError m, MonadSqlQuery m) + => Bool + -> BudgetSpan + -> HistorySpan + -> m (Bool, Bool) +readScopeChanged dbempty bscope hscope = do rs <- dumpTbl case rs of - [] -> return (True, True) + [] -> if dbempty then return (True, True) else throwError undefined [r] -> do - let (ConfigStateR hsh bsh) = E.entityVal r - return - ( hashScope budgetInterval == bsh - , hashScope statementInterval == hsh - ) + let (ConfigStateR h b) = E.entityVal r + return (bscope /= b, hscope /= h) _ -> throwError undefined - where - hashScope f = hash $ f s makeTxCRUD :: (MonadInsertError m, MonadSqlQuery m, Hashable a) @@ -202,13 +200,13 @@ makeTxCRUD DeleteTxs ) makeTxCRUD existing newThings curThings scopeChanged = do - let (toDelHashes, overlap, toIns) = setDiffWith go curThings newThings + let (toDelHashes, overlap, toIns) = + setDiffWith (\a b -> hash b == a) curThings newThings -- Check the overlap for rows with accounts/tags/currencies that -- won't exist on the next update. Those with invalid IDs will be set aside -- to delete and reinsert (which may also fail) later - (toInsRetry, noRetry) <- readInvalidIds existing overlap - let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry) - let toInsAll = (snd <$> toInsRetry) ++ toIns + (noRetry, toInsRetry) <- readInvalidIds existing overlap + let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry -- If we are inserting or deleting something or the scope changed, pull out -- the remainder of the entries to update/read as we are (re)inserting other -- stuff (this is necessary because a given transaction may depend on the @@ -218,8 +216,6 @@ makeTxCRUD existing newThings curThings scopeChanged = do _ -> readUpdates noRetry toDelAll <- readTxIds toDelAllHashes return $ CRUDOps toInsAll toRead toUpdate toDelAll - where - go a b = hash b == a readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs readTxIds cs = do @@ -270,10 +266,10 @@ currency2Record :: Currency -> Entity CurrencyR currency2Record c@Currency {curSymbol, curFullname, curPrecision} = Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) -readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a] -readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do +readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a] +readCurrentIds = fmap (E.unValue <$>) $ selectE $ do rs <- E.from E.table - return (rs ^. f) + return (rs ^. E.persistIdField) readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int]) readCurrentCommits = do @@ -286,8 +282,8 @@ readCurrentCommits = do let y = E.unValue x in case E.unValue t of CTBudget -> (y : bs, ts, hs) - CTTransfer -> (bs, y : ts, hs) - CTHistory -> (bs, ts, y : hs) + CTHistoryTransfer -> (bs, y : ts, hs) + CTHistoryStatement -> (bs, ts, y : hs) -- hashConfig :: [Budget] -> [History] -> [Int] -- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) @@ -311,13 +307,16 @@ setDiffWith f = go [] [] where go inA inBoth [] bs = (inA, inBoth, bs) go inA inBoth as [] = (as ++ inA, inBoth, []) - go inA inBoth (a : as) bs = case inB a bs of - Just (b, bs') -> go inA ((a, b) : inBoth) as bs' - Nothing -> go (a : inA) inBoth as bs - inB _ [] = Nothing - inB a (b : bs) - | f a b = Just (b, bs) - | otherwise = inB a bs + go inA inBoth (a : as) bs = + let (res, bs') = findDelete (f a) bs + in case res of + Nothing -> go (a : inA) inBoth as bs + Just b -> go inA ((a, b) : inBoth) as bs' + +findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a]) +findDelete f xs = case break f xs of + (ys, []) -> (Nothing, ys) + (ys, z : zs) -> (Just z, ys ++ zs) -- getDBHashes :: MonadSqlQuery m => m [Int] -- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl @@ -594,23 +593,24 @@ updateDBState = do deleteTxs =<< asks (coDelete . csBudgets) deleteTxs =<< asks (coDelete . csHistTrans) deleteTxs =<< asks (coDelete . csHistStmts) - --- updateHashes u --- updateTags u --- updateAccounts u --- updateCurrencies u + b <- asks csBudgetScope + h <- asks csHistoryScope + repsertE (E.toSqlKey 1) $ ConfigStateR h b deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) +repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m () +repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r) + selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r] selectE q = unsafeLiftSql "esqueleto-select" (E.select q) deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m () -deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q) +deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q) insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m () -insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q) +insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q) -- whenHash -- :: (Hashable a, MonadFinance m, MonadSqlQuery m) @@ -661,7 +661,7 @@ insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q) -- hs <- askDBState kmNewCommits -- if h `elem` hs then Just . (c,) <$> f else return Nothing -readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([(Int, a)], [Int]) +readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)]) readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do rs <- selectE $ do (commits :& _ :& entrysets :& entries :& tags) <- @@ -673,28 +673,28 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction) `E.innerJoin` E.table `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset) - `E.innerJoin` E.table - `E.on` (\(_ :& _ :& _ :& e :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry) + `E.leftJoin` E.table + `E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry) E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs) return ( commits ^. CommitRHash , entrysets ^. EntrySetRCurrency , entries ^. EntryRAccount - , tags ^. TagRelationRTag + , tags ?. TagRelationRTag ) -- TODO there are faster ways to do this; may/may not matter - let cs = go ecCurrencies (\(i, c, _, _) -> (i, c)) rs - let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs - let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs - let valid = (cs `HS.intersection` as) `HS.intersection` ts - return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs + let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs + let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs + let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs] + let valid = (cs `S.intersection` as) `S.intersection` ts + let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs + return (a0, []) where - go existing f = - HS.fromList + go existing = + S.fromList . fmap (E.unValue . fst) - . L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd) + . L.filter (all (`S.member` existing) . snd) . groupKey id - . fmap f readUpdates :: (MonadInsertError m, MonadSqlQuery m) diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 7d54047..c3d2970 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -41,10 +41,10 @@ readHistTransfer => PairedTransfer -> m [Tx CommitR] readHistTransfer ht = do - bounds <- askDBState csHistoryScope + bounds <- askDBState (unHSpan . csHistoryScope) expandTransfer c historyName bounds ht where - c = CommitR (hash ht) CTTransfer + c = CommitR (hash ht) CTHistoryTransfer -------------------------------------------------------------------------------- -- Statements @@ -56,10 +56,10 @@ readHistStmt -> m [Tx CommitR] readHistStmt root i = do bs <- readImport root i - bounds <- askDBState csHistoryScope + bounds <- askDBState (unHSpan . csHistoryScope) return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs where - c = CommitR (hash i) CTTransfer + c = CommitR (hash i) CTHistoryStatement -- TODO this probably won't scale well (pipes?) readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()] diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 17ca681..812363b 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -22,47 +22,54 @@ share CommitR sql=commits hash Int type ConfigType + UniqueCommitHash hash deriving Show Eq Ord ConfigStateR sql=config_state - historyScopeHash Int - budgetScopeHash Int + historySpan HistorySpan + budgetSpan BudgetSpan + deriving Show CurrencyR sql=currencies symbol CurID fullname T.Text precision Int - deriving Show Eq + UniqueCurrencySymbol symbol + UniqueCurrencyFullname fullname + deriving Show Eq Ord TagR sql=tags symbol TagID fullname T.Text - deriving Show Eq + UniqueTagSymbol symbol + UniqueTagFullname fullname + deriving Show Eq Ord AccountR sql=accounts name T.Text fullpath AcntPath desc T.Text sign AcntSign leaf Bool - deriving Show Eq + UniqueAccountFullpath fullpath + deriving Show Eq Ord AccountPathR sql=account_paths - parent AccountRId OnDeleteCascade - child AccountRId OnDeleteCascade + parent AccountRId + child AccountRId depth Int - deriving Show Eq + deriving Show Eq Ord TransactionR sql=transactions - commit CommitRId OnDeleteCascade + commit CommitRId date Day description T.Text budgetName T.Text priority Int deriving Show Eq EntrySetR sql=entry_sets - transaction TransactionRId OnDeleteCascade - currency CurrencyRId OnDeleteCascade + transaction TransactionRId + currency CurrencyRId index Int rebalance Bool deriving Show Eq EntryR sql=entries - entryset EntrySetRId OnDeleteCascade - account AccountRId OnDeleteCascade + entryset EntrySetRId + account AccountRId memo T.Text value Rational index Int @@ -71,12 +78,20 @@ EntryR sql=entries cachedLink (Maybe Int) deriving Show Eq TagRelationR sql=tag_relations - entry EntryRId OnDeleteCascade - tag TagRId OnDeleteCascade + entry EntryRId + tag TagRId deriving Show Eq |] -data ConfigType = CTBudget | CTTransfer | CTHistory +type DaySpan = (Day, Int) + +newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan} + deriving newtype (Show, Eq, PersistField, PersistFieldSql) + +newtype HistorySpan = HistorySpan {unHSpan :: DaySpan} + deriving newtype (Show, Eq, PersistField, PersistFieldSql) + +data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement deriving (Eq, Show, Read, Enum, Ord) instance PersistFieldSql ConfigType where diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 5d96fb7..9872ae2 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -39,6 +39,7 @@ data DeleteTxs = DeleteTxs , dtEntries :: ![EntryRId] , dtTagRelations :: ![TagRelationRId] } + deriving (Show) type CDOps c d = CRUDOps [c] () () [d] @@ -53,14 +54,15 @@ data ConfigState = ConfigState , csAccountMap :: !AccountMap , csCurrencyMap :: !CurrencyMap , csTagMap :: !TagMap - , csBudgetScope :: !DaySpan - , csHistoryScope :: !DaySpan + , csBudgetScope :: !BudgetSpan + , csHistoryScope :: !HistorySpan } + deriving (Show) data ExistingConfig = ExistingConfig - { ecAccounts :: !(HashSet Int) - , ecTags :: !(HashSet Int) - , ecCurrencies :: !(HashSet Int) + { ecAccounts :: !(Set AccountRId) + , ecTags :: !(Set TagRId) + , ecCurrencies :: !(Set CurrencyRId) } type AccountMap = M.Map AcntID (AccountRId, AcntType) @@ -78,6 +80,7 @@ data CRUDOps c r u d = CRUDOps , coUpdate :: !u , coDelete :: !d } + deriving (Show) data DBState_ = DBState_ { dbsCurrencyMap :: !CurrencyMap @@ -198,8 +201,6 @@ data TxRecord = TxRecord } deriving (Show, Eq, Ord) -type DaySpan = (Day, Natural) - data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) accountSign :: AcntType -> AcntSign diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index b3a8e54..7d18586 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -151,7 +151,7 @@ askDays -> Maybe Interval -> m [Day] askDays dp i = do - globalSpan <- askDBState csBudgetScope + globalSpan <- askDBState (unBSpan . csBudgetScope) case i of Just i' -> do localSpan <- liftExcept $ resolveDaySpan i'