WIP split IO actions into stages

This commit is contained in:
Nathan Dwarshuis 2023-05-13 13:53:43 -04:00
parent b3276132e3
commit 397a78ddfb
4 changed files with 150 additions and 77 deletions

View File

@ -2,8 +2,12 @@
module Main (main) where module Main (main) where
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import qualified Data.Text.IO as TI import qualified Data.Text.IO as TI
import Database.Persist.Monad
import Internal.Config import Internal.Config
import Internal.Database.Ops import Internal.Database.Ops
import Internal.Insert import Internal.Insert
@ -158,11 +162,28 @@ runDumpAccountKeys c = do
runSync :: FilePath -> IO () runSync :: FilePath -> IO ()
runSync c = do runSync c = do
config <- readConfig c config <- readConfig c
handle err $ runDB (sqlConfig config) $ do let (hTs, hSs) = splitHistory $ statements config
let bgtRes = liftIOExceptT $ mapErrors insertBudget $ budget config pool <- runNoLoggingT $ mkPool $ sqlConfig config
let histRes = mapErrorsIO insertStatement $ statements config handle err $ do
s <- fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config -- _ <- askLoggerIO
flip runReaderT s $ combineErrorIO2 bgtRes histRes $ \_ _ -> ()
-- 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 where
err (InsertException es) = do err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es liftIO $ mapM_ TI.putStrLn $ concatMap showError es

View File

@ -2,10 +2,12 @@ module Internal.Database.Ops
( runDB ( runDB
, nukeTables , nukeTables
, updateHashes , updateHashes
, updateDBState
, getDBState , getDBState
, tree2Records , tree2Records
, flattenAcntRoot , flattenAcntRoot
, paths2IDs , paths2IDs
, mkPool
) )
where where
@ -134,12 +136,6 @@ getConfigHashes c = do
dh <- getDBHashes dh <- getDBHashes
return $ setDiff dh ch 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 :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
dumpTbl = selectE $ E.from E.table dumpTbl = selectE $ E.from E.table
@ -164,18 +160,6 @@ deleteTag e = deleteE $ do
where where
k = entityKey e 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... -- TODO slip-n-slide code...
insertFull insertFull
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
@ -183,15 +167,6 @@ insertFull
-> m () -> m ()
insertFull (Entity k v) = insertKey k v 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 :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname, curPrecision} = currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral 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 :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
toKey = toSqlKey . fromIntegral . hash toKey = toSqlKey . fromIntegral . hash
@ -327,25 +290,74 @@ getDBState
=> Config => Config
-> m (FilePath -> DBState) -> m (FilePath -> DBState)
getDBState c = do getDBState c = do
am <- updateAccounts $ accounts c (del, new) <- getConfigHashes c
cm <- updateCurrencies $ currencies c
ts <- updateTags $ tags c
hs <- updateHashes c
-- TODO not sure how I feel about this, probably will change this struct alot -- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now -- in the future so whatever...for now
combineError bi si $ \b s f -> 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 DBState
{ kmCurrency = cm { kmCurrency = currencyMap cs
, kmAccount = am , kmAccount = am
, kmBudgetInterval = b , kmBudgetInterval = b
, kmStatementInterval = s , kmStatementInterval = s
, kmNewCommits = hs , kmNewCommits = new
, kmOldCommits = del
, kmConfigDir = f , kmConfigDir = f
, kmTag = ts , kmTag = tagMap ts
, kmTagAll = ts
, kmAcntPaths = paths
, kmAcntsOld = acnts
, kmCurrenciesOld = cs
} }
where where
bi = liftExcept $ resolveBounds $ budgetInterval $ global c bi = liftExcept $ resolveBounds $ budgetInterval $ global c
si = liftExcept $ resolveBounds $ statementInterval $ 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 :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)

View File

@ -1,6 +1,9 @@
module Internal.Insert module Internal.Insert
( insertStatement ( insertBudget
, insertBudget , splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
) )
where where
@ -116,7 +119,10 @@ withDates dp f = do
-- 4. assign shadow transactions (TODO) -- 4. assign shadow transactions (TODO)
-- 5. insert all transactions -- 5. insert all transactions
insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget -> m () insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
-> m [UnbalancedTransfer]
insertBudget insertBudget
b@Budget b@Budget
{ bgtLabel { bgtLabel
@ -127,16 +133,15 @@ insertBudget
, bgtTax , bgtTax
, bgtPosttax , bgtPosttax
} = } =
whenHash CTBudget b () $ \key -> do whenHash CTBudget b [] $ \key -> do
intAllos <- combineError3 pre_ tax_ post_ (,,) 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 let res2 = expandTransfers key bgtLabel bgtTransfers
txs <- combineError (concat <$> res1) res2 (++) txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
let bals = balanceTransfers $ txs ++ shadow void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
_ <- combineErrors $ fmap insertBudgetTx bals return $ shadow ++ txs
return ()
where where
pre_ = sortAllos bgtPretax pre_ = sortAllos bgtPretax
tax_ = sortAllos bgtTax tax_ = sortAllos bgtTax
@ -251,11 +256,13 @@ data FlatTransfer v = FlatTransfer
, cbtMeta :: !BudgetMeta , cbtMeta :: !BudgetMeta
, cbtCur :: !BudgetCurrency , cbtCur :: !BudgetCurrency
} }
deriving (Show)
data UnbalancedValue = UnbalancedValue data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType { cvType :: !BudgetTransferType
, cvValue :: !Rational , cvValue :: !Rational
} }
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue type UnbalancedTransfer = FlatTransfer UnbalancedValue
@ -529,18 +536,24 @@ checkAcntTypes ts i = go =<< lookupAccountType i
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- statements -- statements
insertStatement splitHistory :: [History] -> ([HistTransfer], [Statement])
:: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) splitHistory = partitionEithers . fmap go
=> History where
-> m () go (HistTransfer x) = Left x
insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m go (HistStatement x) = Right x
insertStatement (HistStatement i) = insertImport i
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) :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer => HistTransfer
-> m () -> m ()
insertManual insertHistTransfer
m@Transfer m@Transfer
{ transFrom = from { transFrom = from
, transTo = to , transTo = to
@ -558,17 +571,28 @@ insertManual
mapM_ (insertTx c) keys mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts void $ combineErrors $ fmap go amts
insertImport readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
:: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) readHistStmt i = whenHash_ CTImport i $ do
=> 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 bs <- readImport i
bounds <- expandBounds <$> askDBState kmStatementInterval bounds <- expandBounds <$> askDBState kmStatementInterval
keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
mapM_ (insertTx c) keys
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 -- low-level transaction stuff
@ -667,7 +691,6 @@ lookupFinance
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
-- TODO this hashes twice (not that it really matters) -- TODO this hashes twice (not that it really matters)
-- TODO generalize this (persistent mtl)
whenHash whenHash
:: (Hashable a, MonadFinance m, MonadSqlQuery m) :: (Hashable a, MonadFinance m, MonadSqlQuery m)
@ -680,3 +703,15 @@ whenHash t o def f = do
let h = hash o let h = hash o
hs <- askDBState kmNewCommits hs <- askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def 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

View File

@ -597,7 +597,12 @@ data DBState = DBState
, kmBudgetInterval :: !Bounds , kmBudgetInterval :: !Bounds
, kmStatementInterval :: !Bounds , kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int] , kmNewCommits :: ![Int]
, kmOldCommits :: ![Int]
, kmConfigDir :: !FilePath , kmConfigDir :: !FilePath
, kmTagAll :: ![Entity TagR]
, kmAcntPaths :: ![AccountPathR]
, kmAcntsOld :: ![Entity AccountR]
, kmCurrenciesOld :: ![Entity CurrencyR]
} }
type CurrencyM = Reader CurrencyMap type CurrencyM = Reader CurrencyMap