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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
app/Main.hs
View File

@ -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

104
lib/Internal/Database/Ops.hs
View File

@ -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)

87
lib/Internal/Insert.hs
View File

@ -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

5
lib/Internal/Types.hs
View File

@ -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