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
|
||||
|
||||
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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue