WIP split IO actions into stages
This commit is contained in:
parent
b3276132e3
commit
397a78ddfb
31
app/Main.hs
31
app/Main.hs
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue