From 397a78ddfb76b81903b54ec2741cb98c82454fb3 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 13 May 2023 13:53:43 -0400 Subject: [PATCH] WIP split IO actions into stages --- app/Main.hs | 31 +++++++++-- lib/Internal/Database/Ops.hs | 104 +++++++++++++++++++---------------- lib/Internal/Insert.hs | 87 ++++++++++++++++++++--------- lib/Internal/Types.hs | 5 ++ 4 files changed, 150 insertions(+), 77 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index a0f39d7..715f85c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,8 +2,12 @@ module Main (main) where +import Control.Monad.Except +import Control.Monad.IO.Rerunnable +import Control.Monad.Logger import Control.Monad.Reader import qualified Data.Text.IO as TI +import Database.Persist.Monad import Internal.Config import Internal.Database.Ops import Internal.Insert @@ -158,11 +162,28 @@ runDumpAccountKeys c = do runSync :: FilePath -> IO () runSync c = do config <- readConfig c - handle err $ runDB (sqlConfig config) $ do - let bgtRes = liftIOExceptT $ mapErrors insertBudget $ budget config - let histRes = mapErrorsIO insertStatement $ statements config - s <- fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config - flip runReaderT s $ combineErrorIO2 bgtRes histRes $ \_ _ -> () + let (hTs, hSs) = splitHistory $ statements config + pool <- runNoLoggingT $ mkPool $ sqlConfig config + handle err $ do + -- _ <- askLoggerIO + + -- get the current DB state + s <- runSqlQueryT pool $ do + runMigration migrateAll + fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config + + -- read desired statements from disk + bSs <- flip runReaderT s $ catMaybes <$> mapM readHistStmt hSs + + -- update the DB + runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do + let hTransRes = mapErrors insertHistTransfer hTs + let bgtRes = mapErrors insertBudget $ budget config + updateDBState -- TODO this will only work if foreign keys are deferred + res <- runExceptT $ do + mapM_ (uncurry insertHistStmt) bSs + combineError hTransRes bgtRes $ \_ _ -> () + rerunnableIO $ fromEither res where err (InsertException es) = do liftIO $ mapM_ TI.putStrLn $ concatMap showError es diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 8a09223..f7c95a3 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -2,10 +2,12 @@ module Internal.Database.Ops ( runDB , nukeTables , updateHashes + , updateDBState , getDBState , tree2Records , flattenAcntRoot , paths2IDs + , mkPool ) where @@ -134,12 +136,6 @@ getConfigHashes c = do dh <- getDBHashes return $ setDiff dh ch -updateHashes :: MonadSqlQuery m => Config -> m [Int] -updateHashes c = do - (del, new) <- getConfigHashes c - nukeDBHashes del - return new - dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r] dumpTbl = selectE $ E.from E.table @@ -164,18 +160,6 @@ deleteTag e = deleteE $ do where k = entityKey e -updateAccounts :: MonadSqlQuery m => AccountRoot -> m AccountMap -updateAccounts ar = do - let (acnts, paths, acntMap) = indexAcntRoot ar - acnts' <- dumpTbl - let (toIns, toDel) = setDiff acnts acnts' - deleteWhere ([] :: [Filter AccountPathR]) - mapM_ deleteAccount toDel - -- liftIO $ mapM_ print toDel - mapM_ insertFull toIns - mapM_ insert paths - return acntMap - -- TODO slip-n-slide code... insertFull :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) @@ -183,15 +167,6 @@ insertFull -> m () insertFull (Entity k v) = insertKey k v -updateCurrencies :: MonadSqlQuery m => [Currency] -> m CurrencyMap -updateCurrencies cs = do - let curs = fmap currency2Record cs - curs' <- selectE $ E.from $ E.table @CurrencyR - let (toIns, toDel) = setDiff curs curs' - mapM_ deleteCurrency toDel - mapM_ insertFull toIns - return $ currencyMap curs - currency2Record :: Currency -> Entity CurrencyR currency2Record c@Currency {curSymbol, curFullname, curPrecision} = Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) @@ -206,18 +181,6 @@ currencyMap = ) ) -updateTags :: MonadSqlQuery m => [Tag] -> m TagMap -updateTags cs = do - let tags = fmap toRecord cs - tags' <- selectE $ E.from $ E.table @TagR - let (toIns, toDel) = setDiff tags tags' - mapM_ deleteTag toDel - mapM_ insertFull toIns - return $ tagMap tags - where - toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc - tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) - toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b toKey = toSqlKey . fromIntegral . hash @@ -327,25 +290,74 @@ getDBState => Config -> m (FilePath -> DBState) getDBState c = do - am <- updateAccounts $ accounts c - cm <- updateCurrencies $ currencies c - ts <- updateTags $ tags c - hs <- updateHashes c + (del, new) <- getConfigHashes c -- TODO not sure how I feel about this, probably will change this struct alot -- in the future so whatever...for now combineError bi si $ \b s f -> + -- TODO this can be cleaned up, half of it is meant to be queried when + -- determining how to insert budgets/history and the rest is just + -- holdover data to delete upon successful insertion DBState - { kmCurrency = cm + { kmCurrency = currencyMap cs , kmAccount = am , kmBudgetInterval = b , kmStatementInterval = s - , kmNewCommits = hs + , kmNewCommits = new + , kmOldCommits = del , kmConfigDir = f - , kmTag = ts + , kmTag = tagMap ts + , kmTagAll = ts + , kmAcntPaths = paths + , kmAcntsOld = acnts + , kmCurrenciesOld = cs } where bi = liftExcept $ resolveBounds $ budgetInterval $ global c si = liftExcept $ resolveBounds $ statementInterval $ global c + (acnts, paths, am) = indexAcntRoot $ accounts c + cs = currency2Record <$> currencies c + ts = toRecord <$> tags c + toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc + tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) + +updateHashes :: (MonadFinance m, MonadSqlQuery m) => m () +updateHashes = do + old <- askDBState kmOldCommits + nukeDBHashes old + +updateTags :: (MonadFinance m, MonadSqlQuery m) => m () +updateTags = do + tags <- askDBState kmTagAll + tags' <- selectE $ E.from $ E.table @TagR + let (toIns, toDel) = setDiff tags tags' + mapM_ deleteTag toDel + mapM_ insertFull toIns + +updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m () +updateAccounts = do + acnts <- askDBState kmAcntsOld + paths <- askDBState kmAcntPaths + acnts' <- dumpTbl + let (toIns, toDel) = setDiff acnts acnts' + deleteWhere ([] :: [Filter AccountPathR]) + mapM_ deleteAccount toDel + mapM_ insertFull toIns + mapM_ insert paths + +updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m () +updateCurrencies = do + curs <- askDBState kmCurrenciesOld + curs' <- selectE $ E.from $ E.table @CurrencyR + let (toIns, toDel) = setDiff curs curs' + mapM_ deleteCurrency toDel + mapM_ insertFull toIns + +updateDBState :: (MonadFinance m, MonadSqlQuery m) => m () +updateDBState = do + updateHashes + updateTags + updateAccounts + updateCurrencies deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 531edc1..d9b2bfd 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -1,6 +1,9 @@ module Internal.Insert - ( insertStatement - , insertBudget + ( insertBudget + , splitHistory + , insertHistTransfer + , readHistStmt + , insertHistStmt ) where @@ -116,7 +119,10 @@ withDates dp f = do -- 4. assign shadow transactions (TODO) -- 5. insert all transactions -insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget -> m () +insertBudget + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + => Budget + -> m [UnbalancedTransfer] insertBudget b@Budget { bgtLabel @@ -127,16 +133,15 @@ insertBudget , bgtTax , bgtPosttax } = - whenHash CTBudget b () $ \key -> do + whenHash CTBudget b [] $ \key -> do intAllos <- combineError3 pre_ tax_ post_ (,,) - let res1 = combineErrors $ fmap (insertIncome key bgtLabel intAllos) bgtIncomes + let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes let res2 = expandTransfers key bgtLabel bgtTransfers txs <- combineError (concat <$> res1) res2 (++) m <- askDBState kmCurrency shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs - let bals = balanceTransfers $ txs ++ shadow - _ <- combineErrors $ fmap insertBudgetTx bals - return () + void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow + return $ shadow ++ txs where pre_ = sortAllos bgtPretax tax_ = sortAllos bgtTax @@ -251,11 +256,13 @@ data FlatTransfer v = FlatTransfer , cbtMeta :: !BudgetMeta , cbtCur :: !BudgetCurrency } + deriving (Show) data UnbalancedValue = UnbalancedValue { cvType :: !BudgetTransferType , cvValue :: !Rational } + deriving (Show) type UnbalancedTransfer = FlatTransfer UnbalancedValue @@ -529,18 +536,24 @@ checkAcntTypes ts i = go =<< lookupAccountType i -------------------------------------------------------------------------------- -- statements -insertStatement - :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) - => History - -> m () -insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m -insertStatement (HistStatement i) = insertImport i +splitHistory :: [History] -> ([HistTransfer], [Statement]) +splitHistory = partitionEithers . fmap go + where + go (HistTransfer x) = Left x + go (HistStatement x) = Right x -insertManual +-- insertStatement +-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) +-- => History +-- -> m () +-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m +-- insertStatement (HistStatement i) = insertImport i + +insertHistTransfer :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => HistTransfer -> m () -insertManual +insertHistTransfer m@Transfer { transFrom = from , transTo = to @@ -558,17 +571,28 @@ insertManual mapM_ (insertTx c) keys void $ combineErrors $ fmap go amts -insertImport - :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) - => Statement - -> m () -insertImport i = whenHash CTImport i () $ \c -> do - -- TODO this isn't efficient, the whole file will be read and maybe no - -- transactions will be desired +readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx])) +readHistStmt i = whenHash_ CTImport i $ do bs <- readImport i bounds <- expandBounds <$> askDBState kmStatementInterval - keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs - mapM_ (insertTx c) keys + liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs + +insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m () +insertHistStmt c ks = do + ck <- insert c + mapM_ (insertTx ck) ks + +-- insertImport +-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) +-- => Statement +-- -> m () +-- insertImport i = whenHash CTImport i () $ \c -> do +-- -- TODO this isn't efficient, the whole file will be read and maybe no +-- -- transactions will be desired +-- bs <- readImport i +-- bounds <- expandBounds <$> askDBState kmStatementInterval +-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs +-- mapM_ (insertTx c) keys -------------------------------------------------------------------------------- -- low-level transaction stuff @@ -667,7 +691,6 @@ lookupFinance lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f -- TODO this hashes twice (not that it really matters) --- TODO generalize this (persistent mtl) whenHash :: (Hashable a, MonadFinance m, MonadSqlQuery m) @@ -680,3 +703,15 @@ whenHash t o def f = do let h = hash o hs <- askDBState kmNewCommits if h `elem` hs then f =<< insert (CommitR h t) else return def + +whenHash_ + :: (Hashable a, MonadFinance m) + => ConfigType + -> a + -> m b + -> m (Maybe (CommitR, b)) +whenHash_ t o f = do + let h = hash o + let c = CommitR h t + hs <- askDBState kmNewCommits + if h `elem` hs then Just . (c,) <$> f else return Nothing diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index d42dac9..f5e7be5 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -597,7 +597,12 @@ data DBState = DBState , kmBudgetInterval :: !Bounds , kmStatementInterval :: !Bounds , kmNewCommits :: ![Int] + , kmOldCommits :: ![Int] , kmConfigDir :: !FilePath + , kmTagAll :: ![Entity TagR] + , kmAcntPaths :: ![AccountPathR] + , kmAcntsOld :: ![Entity AccountR] + , kmCurrenciesOld :: ![Entity CurrencyR] } type CurrencyM = Reader CurrencyMap