FIX history updates
This commit is contained in:
parent
e6f97651e5
commit
bd94afd30f
46
app/Main.hs
46
app/Main.hs
|
@ -4,18 +4,13 @@ module Main (main) where
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.IO.Rerunnable
|
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Reader
|
|
||||||
import Data.Bitraversable
|
import Data.Bitraversable
|
||||||
-- import Data.Hashable
|
-- import Data.Hashable
|
||||||
import qualified Data.Text.IO as TI
|
import qualified Data.Text.IO as TI
|
||||||
import qualified Database.Esqueleto.Experimental as E
|
import qualified Database.Esqueleto.Experimental as E
|
||||||
import Database.Persist.Monad
|
|
||||||
import qualified Dhall hiding (double, record)
|
import qualified Dhall hiding (double, record)
|
||||||
import Internal.Budget
|
|
||||||
import Internal.Database
|
import Internal.Database
|
||||||
import Internal.History
|
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
|
@ -72,7 +67,7 @@ options =
|
||||||
<|> getConf dumpCurrencies
|
<|> getConf dumpCurrencies
|
||||||
<|> getConf dumpAccounts
|
<|> getConf dumpAccounts
|
||||||
<|> getConf dumpAccountKeys
|
<|> getConf dumpAccountKeys
|
||||||
<|> getConf sync
|
<|> getConf sync_
|
||||||
where
|
where
|
||||||
getConf m = Options <$> configFile <*> m
|
getConf m = Options <$> configFile <*> m
|
||||||
|
|
||||||
|
@ -113,8 +108,8 @@ dumpAccountKeys =
|
||||||
<> help "Dump all account keys/aliases"
|
<> help "Dump all account keys/aliases"
|
||||||
)
|
)
|
||||||
|
|
||||||
sync :: Parser Mode
|
sync_ :: Parser Mode
|
||||||
sync =
|
sync_ =
|
||||||
flag'
|
flag'
|
||||||
Sync
|
Sync
|
||||||
( long "sync"
|
( long "sync"
|
||||||
|
@ -219,40 +214,7 @@ runSync threads c bs hs = do
|
||||||
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
||||||
putStrLn "doing other stuff"
|
putStrLn "doing other stuff"
|
||||||
setNumCapabilities 1
|
setNumCapabilities 1
|
||||||
handle err $ do
|
handle err $ sync pool root config bs' hs'
|
||||||
-- _ <- askLoggerIO
|
|
||||||
|
|
||||||
-- Get the current DB state.
|
|
||||||
state <- runSqlQueryT pool $ do
|
|
||||||
runMigration migrateAll
|
|
||||||
liftIOExceptT $ readConfigState config bs' hs'
|
|
||||||
|
|
||||||
-- Read raw transactions according to state. If a transaction is already in
|
|
||||||
-- the database, don't read it but record the commit so we can update it.
|
|
||||||
toIns <-
|
|
||||||
flip runReaderT state $ do
|
|
||||||
(CRUDOps hSs _ _ _) <- asks csHistStmts
|
|
||||||
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
|
||||||
(CRUDOps hTs _ _ _) <- asks csHistTrans
|
|
||||||
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
|
||||||
(CRUDOps bTs _ _ _) <- asks csBudgets
|
|
||||||
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
|
|
||||||
return $ concat $ hSs' ++ hTs' ++ bTs'
|
|
||||||
|
|
||||||
-- Update the DB.
|
|
||||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
|
||||||
-- NOTE this must come first (unless we defer foreign keys)
|
|
||||||
updateDBState
|
|
||||||
res <- runExceptT $ do
|
|
||||||
(CRUDOps _ bRs bUs _) <- asks csBudgets
|
|
||||||
(CRUDOps _ tRs tUs _) <- asks csHistTrans
|
|
||||||
(CRUDOps _ sRs sUs _) <- asks csHistStmts
|
|
||||||
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
|
|
||||||
insertAll ebs
|
|
||||||
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
|
||||||
-- whatever error is encountered above in an IO context, but the first
|
|
||||||
-- thrown error should be caught despite possibly needing to be rerun
|
|
||||||
rerunnableIO $ fromEither res
|
|
||||||
where
|
where
|
||||||
root = takeDirectory c
|
root = takeDirectory c
|
||||||
err (AppException es) = do
|
err (AppException es) = do
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
module Internal.Budget (readBudget) where
|
module Internal.Budget (readBudgetCRUD) where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Decimal hiding (allocate)
|
import Data.Decimal hiding (allocate)
|
||||||
|
@ -13,7 +13,12 @@ import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
|
readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
|
||||||
|
readBudgetCRUD o@CRUDOps {coCreate} = do
|
||||||
|
bs <- mapM readBudget coCreate
|
||||||
|
return $ o {coCreate = bs}
|
||||||
|
|
||||||
|
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR])
|
||||||
readBudget
|
readBudget
|
||||||
b@Budget
|
b@Budget
|
||||||
{ bgtLabel
|
{ bgtLabel
|
||||||
|
@ -27,12 +32,12 @@ readBudget
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
spanRes <- getSpan
|
spanRes <- getSpan
|
||||||
case spanRes of
|
(bgtLabel,) <$> case spanRes of
|
||||||
Nothing -> return []
|
Nothing -> return []
|
||||||
Just budgetSpan -> do
|
Just budgetSpan -> do
|
||||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||||
let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
|
let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
|
||||||
let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
|
let res2 = expandTransfers c budgetSpan bgtTransfers
|
||||||
txs <- combineError (concat <$> res1) res2 (++)
|
txs <- combineError (concat <$> res1) res2 (++)
|
||||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||||
return $ txs ++ shadow
|
return $ txs ++ shadow
|
||||||
|
@ -49,7 +54,7 @@ readBudget
|
||||||
++ (alloAcnt <$> bgtTax)
|
++ (alloAcnt <$> bgtTax)
|
||||||
++ (alloAcnt <$> bgtPosttax)
|
++ (alloAcnt <$> bgtPosttax)
|
||||||
getSpan = do
|
getSpan = do
|
||||||
globalSpan <- asks (unBSpan . csBudgetScope)
|
globalSpan <- asks (unBSpan . tsBudgetScope)
|
||||||
case bgtInterval of
|
case bgtInterval of
|
||||||
Nothing -> return $ Just globalSpan
|
Nothing -> return $ Just globalSpan
|
||||||
Just bi -> do
|
Just bi -> do
|
||||||
|
@ -78,14 +83,12 @@ sortAllo a@Allocation {alloAmts = as} = do
|
||||||
readIncome
|
readIncome
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> CommitR
|
=> CommitR
|
||||||
-> BudgetName
|
|
||||||
-> IntAllocations
|
-> IntAllocations
|
||||||
-> DaySpan
|
-> DaySpan
|
||||||
-> Income
|
-> Income
|
||||||
-> m [Tx CommitR]
|
-> m [Tx CommitR]
|
||||||
readIncome
|
readIncome
|
||||||
key
|
key
|
||||||
name
|
|
||||||
(intPre, intTax, intPost)
|
(intPre, intTax, intPost)
|
||||||
ds
|
ds
|
||||||
Income
|
Income
|
||||||
|
@ -154,9 +157,9 @@ readIncome
|
||||||
, txDate = day
|
, txDate = day
|
||||||
, txPrimary = Left primary
|
, txPrimary = Left primary
|
||||||
, txOther = []
|
, txOther = []
|
||||||
, txDescr = TxDesc ""
|
, txDesc = TxDesc ""
|
||||||
, txBudget = name
|
, -- , txBudget = name
|
||||||
, txPriority = incPriority
|
txPriority = incPriority
|
||||||
}
|
}
|
||||||
|
|
||||||
periodScaler
|
periodScaler
|
||||||
|
|
|
@ -1,8 +1,11 @@
|
||||||
|
{-# LANGUAGE ImplicitPrelude #-}
|
||||||
|
|
||||||
module Internal.Database
|
module Internal.Database
|
||||||
( runDB
|
( runDB
|
||||||
, readConfigState
|
, readDB
|
||||||
, nukeTables
|
, nukeTables
|
||||||
, updateDBState
|
, updateMeta
|
||||||
|
-- , updateDBState
|
||||||
, tree2Records
|
, tree2Records
|
||||||
, flattenAcntRoot
|
, flattenAcntRoot
|
||||||
, indexAcntRoot
|
, indexAcntRoot
|
||||||
|
@ -10,13 +13,14 @@ module Internal.Database
|
||||||
, mkPool
|
, mkPool
|
||||||
, insertEntry
|
, insertEntry
|
||||||
, readUpdates
|
, readUpdates
|
||||||
, insertAll
|
|
||||||
, updateTx
|
, updateTx
|
||||||
|
, sync
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Conduit
|
import Conduit
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
import Control.Monad.IO.Rerunnable
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Data.Decimal
|
import Data.Decimal
|
||||||
import Data.Hashable
|
import Data.Hashable
|
||||||
|
@ -36,7 +40,9 @@ import Database.Persist.Sqlite hiding
|
||||||
, (==.)
|
, (==.)
|
||||||
, (||.)
|
, (||.)
|
||||||
)
|
)
|
||||||
import GHC.Err
|
-- import GHC.Err
|
||||||
|
import Internal.Budget
|
||||||
|
import Internal.History
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||||
|
@ -46,6 +52,52 @@ import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Set as S
|
import qualified RIO.Set as S
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
|
sync
|
||||||
|
:: (MonadUnliftIO m, MonadRerunnableIO m)
|
||||||
|
=> ConnectionPool
|
||||||
|
-> FilePath
|
||||||
|
-> Config
|
||||||
|
-> [Budget]
|
||||||
|
-> [History]
|
||||||
|
-> m ()
|
||||||
|
sync pool root c bs hs = do
|
||||||
|
-- _ <- askLoggerIO
|
||||||
|
|
||||||
|
(meta, txState, budgets, history) <- runSqlQueryT pool $ do
|
||||||
|
runMigration migrateAll
|
||||||
|
liftIOExceptT $ readDB c bs hs
|
||||||
|
|
||||||
|
-- Read raw transactions according to state. If a transaction is already in
|
||||||
|
-- the database, don't read it but record the commit so we can update it.
|
||||||
|
(budgets', history') <-
|
||||||
|
flip runReaderT txState $ do
|
||||||
|
-- TODO collect errors here
|
||||||
|
b <- liftIOExceptT $ readBudgetCRUD budgets
|
||||||
|
h <- readHistoryCRUD root history
|
||||||
|
return (b, h)
|
||||||
|
-- liftIO $ print $ length $ coCreate budgets
|
||||||
|
liftIO $ print $ length $ fst $ coCreate history
|
||||||
|
liftIO $ print $ bimap length length $ coCreate history
|
||||||
|
liftIO $ print $ length $ coRead history
|
||||||
|
liftIO $ print $ length $ coUpdate history
|
||||||
|
liftIO $ print $ (\(DeleteTxs e a b c' d) -> (length e, length a, length b, length c', length d)) $ coDelete history
|
||||||
|
-- liftIO $ print $ length $ M.elems $ tsAccountMap txState
|
||||||
|
-- liftIO $ print $ length $ M.elems $ tsCurrencyMap txState
|
||||||
|
-- liftIO $ print $ length $ M.elems $ tsTagMap txState
|
||||||
|
|
||||||
|
-- Update the DB.
|
||||||
|
runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
|
||||||
|
-- NOTE this must come first (unless we defer foreign keys)
|
||||||
|
updateMeta meta
|
||||||
|
res <- runExceptT $ do
|
||||||
|
-- TODO multithread this :)
|
||||||
|
insertBudgets budgets'
|
||||||
|
insertHistory history'
|
||||||
|
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
||||||
|
-- whatever error is encountered above in an IO context, but the first
|
||||||
|
-- thrown error should be caught despite possibly needing to be rerun
|
||||||
|
rerunnableIO $ fromEither res
|
||||||
|
|
||||||
runDB
|
runDB
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
=> SqlConfig
|
=> SqlConfig
|
||||||
|
@ -106,58 +158,116 @@ nukeTables = do
|
||||||
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
||||||
-- toBal = maybe "???" (fmtRational 2) . unValue
|
-- toBal = maybe "???" (fmtRational 2) . unValue
|
||||||
|
|
||||||
readConfigState
|
readDB
|
||||||
:: (MonadAppError m, MonadSqlQuery m)
|
:: (MonadAppError m, MonadSqlQuery m)
|
||||||
=> Config
|
=> Config
|
||||||
-> [Budget]
|
-> [Budget]
|
||||||
-> [History]
|
-> [History]
|
||||||
-> m ConfigState
|
-> m (MetaCRUD, TxState, PreBudgetCRUD, PreHistoryCRUD)
|
||||||
readConfigState c bs hs = do
|
readDB c bs hs = do
|
||||||
(acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
|
curAcnts <- readCurrentIds
|
||||||
(pathsIns, _, pathsDel) <- diff newPaths
|
curPaths <- readCurrentIds
|
||||||
(curs2Ins, cursRem, curs2Del) <- diff newCurs
|
curCurs <- readCurrentIds
|
||||||
(tags2Ins, tagsRem, tags2Del) <- diff newTags
|
curTags <- readCurrentIds
|
||||||
let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
|
|
||||||
let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
|
|
||||||
let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
|
|
||||||
let fromMap f = S.fromList . fmap f . M.elems
|
|
||||||
let existing =
|
|
||||||
ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
|
|
||||||
|
|
||||||
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
|
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
|
||||||
-- TODO refine this test to include the whole db (with data already mixed
|
|
||||||
-- in this algorithm)
|
|
||||||
let bsRes = BudgetSpan <$> resolveScope budgetInterval
|
let bsRes = BudgetSpan <$> resolveScope budgetInterval
|
||||||
let hsRes = HistorySpan <$> resolveScope statementInterval
|
let hsRes = HistorySpan <$> resolveScope statementInterval
|
||||||
combineErrorM bsRes hsRes $ \bscope hscope -> do
|
combineErrorM bsRes hsRes $ \bscope hscope -> do
|
||||||
let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
|
-- ASSUME the db must be empty if these are empty
|
||||||
|
let dbempty = null curAcnts && null curCurs && null curTags
|
||||||
|
let meta =
|
||||||
|
MetaCRUD
|
||||||
|
{ mcCurrencies = makeCD newCurs curCurs
|
||||||
|
, mcTags = makeCD newTags curTags
|
||||||
|
, mcAccounts = makeCD newAcnts curAcnts
|
||||||
|
, mcPaths = makeCD newPaths curPaths
|
||||||
|
, mcBudgetScope = bscope
|
||||||
|
, mcHistoryScope = hscope
|
||||||
|
}
|
||||||
|
let txS =
|
||||||
|
TxState
|
||||||
|
{ tsAccountMap = amap
|
||||||
|
, tsCurrencyMap = cmap
|
||||||
|
, tsTagMap = tmap
|
||||||
|
, tsBudgetScope = bscope
|
||||||
|
, tsHistoryScope = hscope
|
||||||
|
}
|
||||||
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
|
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
|
||||||
bgt <- makeTxCRUD existing bs curBgts bChanged
|
budgets <- makeBudgetCRUD existing bs curBgts bChanged
|
||||||
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
|
history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged
|
||||||
hStmt <- makeTxCRUD existing ss curHistSts hChanged
|
return (meta, txS, budgets, history)
|
||||||
|
|
||||||
return $
|
|
||||||
ConfigState
|
|
||||||
{ csCurrencies = CRUDOps curs2Ins () () curs2Del
|
|
||||||
, csTags = CRUDOps tags2Ins () () tags2Del
|
|
||||||
, csAccounts = CRUDOps acnts2Ins () () acnts2Del
|
|
||||||
, csPaths = CRUDOps pathsIns () () pathsDel
|
|
||||||
, csBudgets = bgt
|
|
||||||
, csHistTrans = hTrans
|
|
||||||
, csHistStmts = hStmt
|
|
||||||
, csAccountMap = amap
|
|
||||||
, csCurrencyMap = cmap
|
|
||||||
, csTagMap = tmap
|
|
||||||
, csBudgetScope = bscope
|
|
||||||
, csHistoryScope = hscope
|
|
||||||
}
|
|
||||||
where
|
where
|
||||||
(ts, ss) = splitHistory hs
|
(ts, ss) = splitHistory hs
|
||||||
diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
|
makeCD new old =
|
||||||
|
let (cs, _, ds) = setDiffWith (\a b -> E.entityKey a == b) new old
|
||||||
|
in CRUDOps cs () () ds
|
||||||
(newAcnts, newPaths) = indexAcntRoot $ accounts c
|
(newAcnts, newPaths) = indexAcntRoot $ accounts c
|
||||||
newTags = tag2Record <$> tags c
|
newTags = tag2Record <$> tags c
|
||||||
newCurs = currency2Record <$> currencies c
|
newCurs = currency2Record <$> currencies c
|
||||||
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
|
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
|
||||||
|
amap = makeAcntMap newAcnts
|
||||||
|
cmap = currencyMap newCurs
|
||||||
|
tmap = makeTagMap newTags
|
||||||
|
fromMap f = S.fromList . fmap f . M.elems
|
||||||
|
existing = ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
|
||||||
|
|
||||||
|
makeBudgetCRUD
|
||||||
|
:: MonadSqlQuery m
|
||||||
|
=> ExistingConfig
|
||||||
|
-> [Budget]
|
||||||
|
-> [CommitHash]
|
||||||
|
-> Bool
|
||||||
|
-> m (CRUDOps [Budget] () () DeleteTxs)
|
||||||
|
makeBudgetCRUD existing new old scopeChanged = do
|
||||||
|
(toIns, toDel) <-
|
||||||
|
if scopeChanged
|
||||||
|
then (new,) <$> readTxIds old
|
||||||
|
else do
|
||||||
|
let (toDelHashes, overlap, toIns) = setDiffHashes old new
|
||||||
|
toDel <- readTxIds toDelHashes
|
||||||
|
(toInsRetry, _) <- readInvalidIds existing overlap
|
||||||
|
return (toIns ++ (snd <$> toInsRetry), toDel)
|
||||||
|
return $ CRUDOps toIns () () toDel
|
||||||
|
|
||||||
|
makeStatementCRUD
|
||||||
|
:: (MonadAppError m, MonadSqlQuery m)
|
||||||
|
=> ExistingConfig
|
||||||
|
-> ([PairedTransfer], [CommitHash])
|
||||||
|
-> ([Statement], [CommitHash])
|
||||||
|
-> Bool
|
||||||
|
-> m
|
||||||
|
( CRUDOps
|
||||||
|
([PairedTransfer], [Statement])
|
||||||
|
[ReadEntry]
|
||||||
|
[Either TotalUpdateEntrySet FullUpdateEntrySet]
|
||||||
|
DeleteTxs
|
||||||
|
)
|
||||||
|
makeStatementCRUD existing ts ss scopeChanged = do
|
||||||
|
(toInsTs, toDelTs, validTs) <- uncurry diff ts
|
||||||
|
(toInsSs, toDelSs, validSs) <- uncurry diff ss
|
||||||
|
let toDelAllHashes = toDelTs ++ toDelSs
|
||||||
|
-- If we are inserting or deleting something or the scope changed, pull out
|
||||||
|
-- the remainder of the entries to update/read as we are (re)inserting other
|
||||||
|
-- stuff (this is necessary because a given transaction may depend on the
|
||||||
|
-- value of previous transactions, even if they are already in the DB).
|
||||||
|
(toRead, toUpdate) <- case (toInsTs, toInsSs, toDelAllHashes, scopeChanged) of
|
||||||
|
([], [], [], False) -> return ([], [])
|
||||||
|
_ -> readUpdates $ validTs ++ validSs
|
||||||
|
toDelAll <- readTxIds toDelAllHashes
|
||||||
|
return $ CRUDOps (toInsTs, toInsSs) toRead toUpdate toDelAll
|
||||||
|
where
|
||||||
|
diff :: (MonadSqlQuery m, Hashable a) => [a] -> [CommitHash] -> m ([a], [CommitHash], [CommitHash])
|
||||||
|
diff new old = do
|
||||||
|
let (toDelHashes, overlap, toIns) = setDiffHashes old new
|
||||||
|
-- Check the overlap for rows with accounts/tags/currencies that
|
||||||
|
-- won't exist on the next update. Those with invalid IDs will be set aside
|
||||||
|
-- to delete and reinsert (which may also fail) later
|
||||||
|
(invalid, valid) <- readInvalidIds existing overlap
|
||||||
|
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip invalid
|
||||||
|
return (toInsAll, toDelAllHashes, valid)
|
||||||
|
|
||||||
|
setDiffHashes :: Hashable a => [CommitHash] -> [a] -> ([CommitHash], [(CommitHash, a)], [a])
|
||||||
|
setDiffHashes = setDiffWith (\a b -> CommitHash (hash b) == a)
|
||||||
|
|
||||||
readScopeChanged
|
readScopeChanged
|
||||||
:: (MonadAppError m, MonadSqlQuery m)
|
:: (MonadAppError m, MonadSqlQuery m)
|
||||||
|
@ -175,37 +285,6 @@ readScopeChanged dbempty bscope hscope = do
|
||||||
return (bscope /= b, hscope /= h)
|
return (bscope /= b, hscope /= h)
|
||||||
_ -> throwAppError $ DBError DBMultiScope
|
_ -> throwAppError $ DBError DBMultiScope
|
||||||
|
|
||||||
makeTxCRUD
|
|
||||||
:: (MonadAppError m, MonadSqlQuery m, Hashable a)
|
|
||||||
=> ExistingConfig
|
|
||||||
-> [a]
|
|
||||||
-> [CommitHash]
|
|
||||||
-> Bool
|
|
||||||
-> m
|
|
||||||
( CRUDOps
|
|
||||||
[a]
|
|
||||||
[ReadEntry]
|
|
||||||
[Either TotalUpdateEntrySet FullUpdateEntrySet]
|
|
||||||
DeleteTxs
|
|
||||||
)
|
|
||||||
makeTxCRUD existing newThings curThings scopeChanged = do
|
|
||||||
let (toDelHashes, overlap, toIns) =
|
|
||||||
setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
|
|
||||||
-- Check the overlap for rows with accounts/tags/currencies that
|
|
||||||
-- won't exist on the next update. Those with invalid IDs will be set aside
|
|
||||||
-- to delete and reinsert (which may also fail) later
|
|
||||||
(noRetry, toInsRetry) <- readInvalidIds existing overlap
|
|
||||||
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
|
|
||||||
-- If we are inserting or deleting something or the scope changed, pull out
|
|
||||||
-- the remainder of the entries to update/read as we are (re)inserting other
|
|
||||||
-- stuff (this is necessary because a given transaction may depend on the
|
|
||||||
-- value of previous transactions, even if they are already in the DB).
|
|
||||||
(toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
|
|
||||||
([], [], False) -> return ([], [])
|
|
||||||
_ -> readUpdates noRetry
|
|
||||||
toDelAll <- readTxIds toDelAllHashes
|
|
||||||
return $ CRUDOps toInsAll toRead toUpdate toDelAll
|
|
||||||
|
|
||||||
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
|
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
|
||||||
readTxIds cs = do
|
readTxIds cs = do
|
||||||
xs <- selectE $ do
|
xs <- selectE $ do
|
||||||
|
@ -218,33 +297,29 @@ readTxIds cs = do
|
||||||
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
||||||
`E.innerJoin` E.table
|
`E.innerJoin` E.table
|
||||||
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
||||||
`E.innerJoin` E.table
|
`E.leftJoin` E.table
|
||||||
`E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
|
`E.on` (\(_ :& _ :& _ :& e :& t) -> E.just (e ^. EntryRId) ==. t ?. TagRelationREntry)
|
||||||
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
|
||||||
return
|
return
|
||||||
( txs ^. TransactionRId
|
( commits ^. CommitRId
|
||||||
|
, txs ^. TransactionRId
|
||||||
, ess ^. EntrySetRId
|
, ess ^. EntrySetRId
|
||||||
, es ^. EntryRId
|
, es ^. EntryRId
|
||||||
, ts ^. TagRelationRId
|
, ts ?. TagRelationRId
|
||||||
)
|
)
|
||||||
let (txs, ss, es, ts) = L.unzip4 xs
|
let (cms, txs, ss, es, ts) = L.unzip5 xs
|
||||||
return $
|
return $
|
||||||
DeleteTxs
|
DeleteTxs
|
||||||
{ dtTxs = go txs
|
{ dtCommits = go cms
|
||||||
|
, dtTxs = go txs
|
||||||
, dtEntrySets = go ss
|
, dtEntrySets = go ss
|
||||||
, dtEntries = go es
|
, dtEntries = go es
|
||||||
, dtTagRelations = E.unValue <$> ts
|
, dtTagRelations = catMaybes $ E.unValue <$> ts
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
go :: Eq a => [E.Value a] -> [a]
|
go :: Eq a => [E.Value a] -> [a]
|
||||||
go = fmap (E.unValue . NE.head) . NE.group
|
go = fmap (E.unValue . NE.head) . NE.group
|
||||||
|
|
||||||
splitHistory :: [History] -> ([PairedTransfer], [Statement])
|
|
||||||
splitHistory = partitionEithers . fmap go
|
|
||||||
where
|
|
||||||
go (HistTransfer x) = Left x
|
|
||||||
go (HistStatement x) = Right x
|
|
||||||
|
|
||||||
makeTagMap :: [Entity TagR] -> TagMap
|
makeTagMap :: [Entity TagR] -> TagMap
|
||||||
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||||
|
|
||||||
|
@ -255,7 +330,7 @@ currency2Record :: Currency -> Entity CurrencyR
|
||||||
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
||||||
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
|
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
|
||||||
|
|
||||||
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
|
readCurrentIds :: (PersistEntity a, MonadSqlQuery m) => m [Key a]
|
||||||
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
||||||
rs <- E.from E.table
|
rs <- E.from E.table
|
||||||
return (rs ^. E.persistIdField)
|
return (rs ^. E.persistIdField)
|
||||||
|
@ -263,8 +338,8 @@ readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
||||||
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
|
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
|
||||||
readCurrentCommits = do
|
readCurrentCommits = do
|
||||||
xs <- selectE $ do
|
xs <- selectE $ do
|
||||||
rs <- E.from E.table
|
commits <- E.from E.table
|
||||||
return (rs ^. CommitRHash, rs ^. CommitRType)
|
return (commits ^. CommitRHash, commits ^. CommitRType)
|
||||||
return $ foldr go ([], [], []) xs
|
return $ foldr go ([], [], []) xs
|
||||||
where
|
where
|
||||||
go (x, t) (bs, ts, hs) =
|
go (x, t) (bs, ts, hs) =
|
||||||
|
@ -387,39 +462,54 @@ indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . fl
|
||||||
updateCD
|
updateCD
|
||||||
:: ( MonadSqlQuery m
|
:: ( MonadSqlQuery m
|
||||||
, PersistRecordBackend a SqlBackend
|
, PersistRecordBackend a SqlBackend
|
||||||
, PersistRecordBackend b SqlBackend
|
|
||||||
)
|
)
|
||||||
=> CDOps (Entity a) (Key b)
|
=> EntityCRUDOps a
|
||||||
-> m ()
|
-> m ()
|
||||||
updateCD (CRUDOps cs () () ds) = do
|
updateCD (CRUDOps cs () () ds) = do
|
||||||
mapM_ deleteKeyE ds
|
mapM_ deleteKeyE ds
|
||||||
insertEntityManyE cs
|
insertEntityManyE cs
|
||||||
|
|
||||||
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
|
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
|
||||||
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
|
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do
|
||||||
mapM_ deleteKeyE dtTxs
|
|
||||||
mapM_ deleteKeyE dtEntrySets
|
|
||||||
mapM_ deleteKeyE dtEntries
|
|
||||||
mapM_ deleteKeyE dtTagRelations
|
mapM_ deleteKeyE dtTagRelations
|
||||||
|
mapM_ deleteKeyE dtEntries
|
||||||
|
mapM_ deleteKeyE dtEntrySets
|
||||||
|
mapM_ deleteKeyE dtTxs
|
||||||
|
mapM_ deleteKeyE dtCommits
|
||||||
|
|
||||||
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
-- updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||||
updateDBState = do
|
-- updateDBState = do
|
||||||
updateCD =<< asks csCurrencies
|
-- updateCD =<< asks csCurrencies
|
||||||
updateCD =<< asks csAccounts
|
-- updateCD =<< asks csAccounts
|
||||||
updateCD =<< asks csPaths
|
-- updateCD =<< asks csPaths
|
||||||
updateCD =<< asks csTags
|
-- updateCD =<< asks csTags
|
||||||
deleteTxs =<< asks (coDelete . csBudgets)
|
-- -- deleteTxs =<< asks (coDelete . csBudgets)
|
||||||
deleteTxs =<< asks (coDelete . csHistTrans)
|
-- -- deleteTxs =<< asks (coDelete . csHistory)
|
||||||
deleteTxs =<< asks (coDelete . csHistStmts)
|
-- b <- asks csBudgetScope
|
||||||
b <- asks csBudgetScope
|
-- h <- asks csHistoryScope
|
||||||
h <- asks csHistoryScope
|
-- repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
||||||
repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
|
||||||
|
updateMeta :: MonadSqlQuery m => MetaCRUD -> m ()
|
||||||
|
updateMeta
|
||||||
|
MetaCRUD
|
||||||
|
{ mcCurrencies
|
||||||
|
, mcAccounts
|
||||||
|
, mcPaths
|
||||||
|
, mcTags
|
||||||
|
, mcBudgetScope
|
||||||
|
, mcHistoryScope
|
||||||
|
} = do
|
||||||
|
updateCD mcCurrencies
|
||||||
|
updateCD mcAccounts
|
||||||
|
updateCD mcPaths
|
||||||
|
updateCD mcTags
|
||||||
|
repsertE (E.toSqlKey 1) $ ConfigStateR mcHistoryScope mcBudgetScope
|
||||||
|
|
||||||
readInvalidIds
|
readInvalidIds
|
||||||
:: MonadSqlQuery m
|
:: MonadSqlQuery m
|
||||||
=> ExistingConfig
|
=> ExistingConfig
|
||||||
-> [(CommitHash, a)]
|
-> [(CommitHash, a)]
|
||||||
-> m ([CommitHash], [(CommitHash, a)])
|
-> m ([(CommitHash, a)], [CommitHash])
|
||||||
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||||
rs <- selectE $ do
|
rs <- selectE $ do
|
||||||
(commits :& _ :& entrysets :& entries :& tags) <-
|
(commits :& _ :& entrysets :& entries :& tags) <-
|
||||||
|
@ -444,14 +534,13 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||||
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
|
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
|
||||||
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
|
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
|
||||||
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
|
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
|
||||||
let valid = (cs `S.intersection` as) `S.intersection` ts
|
let invalid = (cs `S.union` as) `S.union` ts
|
||||||
let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
|
return $ second (fst <$>) $ L.partition ((`S.member` invalid) . fst) xs
|
||||||
return (a0, [])
|
|
||||||
where
|
where
|
||||||
go existing =
|
go existing =
|
||||||
S.fromList
|
S.fromList
|
||||||
. fmap (E.unValue . fst)
|
. fmap (E.unValue . fst)
|
||||||
. L.filter (all (`S.member` existing) . snd)
|
. L.filter (not . all (`S.member` existing) . snd)
|
||||||
. groupKey id
|
. groupKey id
|
||||||
|
|
||||||
readUpdates
|
readUpdates
|
||||||
|
@ -478,7 +567,6 @@ readUpdates hashes = do
|
||||||
(
|
(
|
||||||
( entrysets ^. EntrySetRId
|
( entrysets ^. EntrySetRId
|
||||||
, txs ^. TransactionRDate
|
, txs ^. TransactionRDate
|
||||||
, txs ^. TransactionRBudgetName
|
|
||||||
, txs ^. TransactionRPriority
|
, txs ^. TransactionRPriority
|
||||||
,
|
,
|
||||||
( entrysets ^. EntrySetRCurrency
|
( entrysets ^. EntrySetRCurrency
|
||||||
|
@ -489,11 +577,11 @@ readUpdates hashes = do
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
||||||
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
|
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _) -> i) (snd <$> toUpdate)
|
||||||
let toRead' = fmap (makeRE . snd) toRead
|
let toRead' = fmap (makeRE . snd) toRead
|
||||||
return (toRead', toUpdate')
|
return (toRead', toUpdate')
|
||||||
where
|
where
|
||||||
makeUES ((_, day, name, pri, (curID, prec)), es) = do
|
makeUES ((_, day, pri, (curID, prec)), es) = do
|
||||||
let prec' = fromIntegral $ E.unValue prec
|
let prec' = fromIntegral $ E.unValue prec
|
||||||
let cur = E.unValue curID
|
let cur = E.unValue curID
|
||||||
let res =
|
let res =
|
||||||
|
@ -520,7 +608,6 @@ readUpdates hashes = do
|
||||||
, utFromUnk = fromUnk
|
, utFromUnk = fromUnk
|
||||||
, utToUnk = toUnk
|
, utToUnk = toUnk
|
||||||
, utTotalValue = realFracToDecimalP prec' tot
|
, utTotalValue = realFracToDecimalP prec' tot
|
||||||
, utBudget = E.unValue name
|
|
||||||
, utPriority = E.unValue pri
|
, utPriority = E.unValue pri
|
||||||
}
|
}
|
||||||
Right x ->
|
Right x ->
|
||||||
|
@ -535,19 +622,17 @@ readUpdates hashes = do
|
||||||
, utFromUnk = fromUnk
|
, utFromUnk = fromUnk
|
||||||
, utToUnk = toUnk
|
, utToUnk = toUnk
|
||||||
, utTotalValue = ()
|
, utTotalValue = ()
|
||||||
, utBudget = E.unValue name
|
|
||||||
, utPriority = E.unValue pri
|
, utPriority = E.unValue pri
|
||||||
}
|
}
|
||||||
-- TODO this error is lame
|
-- TODO this error is lame
|
||||||
_ -> throwAppError $ DBError $ DBUpdateUnbalanced
|
_ -> throwAppError $ DBError DBUpdateUnbalanced
|
||||||
makeRE ((_, day, name, pri, (curID, prec)), entry) = do
|
makeRE ((_, day, pri, (curID, prec)), entry) = do
|
||||||
let e = entityVal entry
|
let e = entityVal entry
|
||||||
in ReadEntry
|
in ReadEntry
|
||||||
{ reDate = E.unValue day
|
{ reDate = E.unValue day
|
||||||
, reCurrency = E.unValue curID
|
, reCurrency = E.unValue curID
|
||||||
, reAcnt = entryRAccount e
|
, reAcnt = entryRAccount e
|
||||||
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
|
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
|
||||||
, reBudget = E.unValue name
|
|
||||||
, rePriority = E.unValue pri
|
, rePriority = E.unValue pri
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -665,8 +750,8 @@ readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) o
|
||||||
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
||||||
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
|
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
|
||||||
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
|
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
|
||||||
(Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
|
(Nothing, Just TBalance) -> err DBLinkInvalidBalance
|
||||||
(Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
|
(Nothing, Just TPercent) -> err DBLinkInvalidPercent
|
||||||
where
|
where
|
||||||
go = return . Right . Right
|
go = return . Right . Right
|
||||||
err = throwAppError . DBError . DBLinkError k
|
err = throwAppError . DBError . DBLinkError k
|
||||||
|
@ -680,21 +765,72 @@ makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRVal
|
||||||
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||||
makeUnkUE k e = makeUE k e ()
|
makeUnkUE k e = makeUE k e ()
|
||||||
|
|
||||||
insertAll
|
-- updateEntries
|
||||||
|
-- :: (MonadSqlQuery m, MonadFinance m, MonadRerunnableIO m)
|
||||||
|
-- => [ ( BudgetName
|
||||||
|
-- , CRUDOps
|
||||||
|
-- [Tx CommitR]
|
||||||
|
-- [ReadEntry]
|
||||||
|
-- [(Either TotalUpdateEntrySet FullUpdateEntrySet)]
|
||||||
|
-- DeleteTxs
|
||||||
|
-- )
|
||||||
|
-- ]
|
||||||
|
-- -> m ()
|
||||||
|
-- updateEntries es = do
|
||||||
|
-- res <- runExceptT $ mapErrors (uncurry insertAll) es
|
||||||
|
-- void $ rerunnableIO $ fromEither res
|
||||||
|
|
||||||
|
insertBudgets
|
||||||
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||||
=> [EntryCRU]
|
=> FinalBudgetCRUD
|
||||||
-> m ()
|
-> m ()
|
||||||
insertAll ebs = do
|
insertBudgets (CRUDOps bs () () ds) = do
|
||||||
(toUpdate, toInsert) <- balanceTxs ebs
|
deleteTxs ds
|
||||||
|
mapM_ go bs
|
||||||
|
where
|
||||||
|
go (name, cs) = do
|
||||||
|
-- TODO useless overhead?
|
||||||
|
(toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
|
||||||
|
mapM_ updateTx toUpdate
|
||||||
|
forM_ (groupWith itxCommit toInsert) $
|
||||||
|
\(c, ts) -> do
|
||||||
|
ck <- insert c
|
||||||
|
mapM_ (insertTx name ck) ts
|
||||||
|
|
||||||
|
insertHistory
|
||||||
|
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||||
|
=> FinalHistoryCRUD
|
||||||
|
-> m ()
|
||||||
|
insertHistory (CRUDOps cs rs us ds) = do
|
||||||
|
(toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
|
||||||
mapM_ updateTx toUpdate
|
mapM_ updateTx toUpdate
|
||||||
forM_ (groupWith itxCommit toInsert) $
|
forM_ (groupWith itxCommit toInsert) $
|
||||||
\(c, ts) -> do
|
\(c, ts) -> do
|
||||||
ck <- insert c
|
ck <- insert c
|
||||||
mapM_ (insertTx ck) ts
|
mapM_ (insertTx historyName ck) ts
|
||||||
|
deleteTxs ds
|
||||||
|
|
||||||
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
-- insertAll
|
||||||
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
|
-- :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||||
k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
|
-- => BudgetName
|
||||||
|
-- -> CRUDOps
|
||||||
|
-- [Tx CommitR]
|
||||||
|
-- [ReadEntry]
|
||||||
|
-- [Either TotalUpdateEntrySet FullUpdateEntrySet]
|
||||||
|
-- DeleteTxs
|
||||||
|
-- -> m ()
|
||||||
|
-- insertAll b (CRUDOps cs rs us ds) = do
|
||||||
|
-- (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
|
||||||
|
-- mapM_ updateTx toUpdate
|
||||||
|
-- forM_ (groupWith itxCommit toInsert) $
|
||||||
|
-- \(c, ts) -> do
|
||||||
|
-- ck <- insert c
|
||||||
|
-- mapM_ (insertTx b ck) ts
|
||||||
|
-- deleteTxs ds
|
||||||
|
|
||||||
|
insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
|
||||||
|
insertTx b c InsertTx {itxDate, itxDesc, itxEntrySets, itxPriority} = do
|
||||||
|
k <- insert $ TransactionR c itxDate b itxDesc itxPriority
|
||||||
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
|
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
|
||||||
where
|
where
|
||||||
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
||||||
|
@ -740,3 +876,6 @@ deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
|
||||||
|
|
||||||
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
|
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
|
||||||
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
|
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
|
||||||
|
|
||||||
|
historyName :: BudgetName
|
||||||
|
historyName = BudgetName "history"
|
||||||
|
|
|
@ -2,6 +2,7 @@ module Internal.History
|
||||||
( readHistStmt
|
( readHistStmt
|
||||||
, readHistTransfer
|
, readHistTransfer
|
||||||
, splitHistory
|
, splitHistory
|
||||||
|
, readHistoryCRUD
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -24,6 +25,20 @@ import qualified RIO.Vector as V
|
||||||
import Text.Regex.TDFA hiding (matchAll)
|
import Text.Regex.TDFA hiding (matchAll)
|
||||||
import Text.Regex.TDFA.Text
|
import Text.Regex.TDFA.Text
|
||||||
|
|
||||||
|
readHistoryCRUD
|
||||||
|
:: (MonadUnliftIO m, MonadFinance m)
|
||||||
|
=> FilePath
|
||||||
|
-> PreHistoryCRUD
|
||||||
|
-> m FinalHistoryCRUD
|
||||||
|
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
|
||||||
|
-- TODO multithread this for some extra fun :)
|
||||||
|
|
||||||
|
ss' <- mapM (readHistStmt root) ss
|
||||||
|
fromEitherM $ runExceptT $ do
|
||||||
|
let sRes = mapErrors (ExceptT . return) ss'
|
||||||
|
let tRes = mapErrors readHistTransfer ts
|
||||||
|
combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
|
||||||
|
|
||||||
-- NOTE keep statement and transfer readers separate because the former needs
|
-- NOTE keep statement and transfer readers separate because the former needs
|
||||||
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
|
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
|
||||||
-- thingy
|
-- thingy
|
||||||
|
@ -41,8 +56,8 @@ readHistTransfer
|
||||||
=> PairedTransfer
|
=> PairedTransfer
|
||||||
-> m [Tx CommitR]
|
-> m [Tx CommitR]
|
||||||
readHistTransfer ht = do
|
readHistTransfer ht = do
|
||||||
bounds <- asks (unHSpan . csHistoryScope)
|
bounds <- asks (unHSpan . tsHistoryScope)
|
||||||
expandTransfer c historyName bounds ht
|
expandTransfer c bounds ht
|
||||||
where
|
where
|
||||||
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
||||||
|
|
||||||
|
@ -53,23 +68,27 @@ readHistStmt
|
||||||
:: (MonadUnliftIO m, MonadFinance m)
|
:: (MonadUnliftIO m, MonadFinance m)
|
||||||
=> FilePath
|
=> FilePath
|
||||||
-> Statement
|
-> Statement
|
||||||
-> m [Tx CommitR]
|
-> m (Either AppException [Tx CommitR])
|
||||||
readHistStmt root i = do
|
readHistStmt root i = do
|
||||||
|
bounds <- asks (unHSpan . tsHistoryScope)
|
||||||
bs <- readImport root i
|
bs <- readImport root i
|
||||||
bounds <- asks (unHSpan . csHistoryScope)
|
return $ filter (inDaySpan bounds . txDate) . fmap (\t -> t {txCommit = c}) <$> bs
|
||||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
|
||||||
where
|
where
|
||||||
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
||||||
|
|
||||||
-- TODO this probably won't scale well (pipes?)
|
-- TODO this probably won't scale well (pipes?)
|
||||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
readImport
|
||||||
|
:: (MonadUnliftIO m, MonadFinance m)
|
||||||
|
=> FilePath
|
||||||
|
-> Statement
|
||||||
|
-> m (Either AppException [Tx ()])
|
||||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||||
let ores = compileOptions stmtTxOpts
|
let ores = compileOptions stmtTxOpts
|
||||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||||
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
||||||
fromEither =<< runExceptT (matchRecords compiledMatches records)
|
runExceptT (matchRecords compiledMatches records)
|
||||||
where
|
where
|
||||||
paths = (root </>) <$> stmtPaths
|
paths = (root </>) <$> stmtPaths
|
||||||
|
|
||||||
|
@ -301,7 +320,7 @@ toTx
|
||||||
combineError curRes subRes $ \(cur, f, t) ss ->
|
combineError curRes subRes $ \(cur, f, t) ss ->
|
||||||
Tx
|
Tx
|
||||||
{ txDate = trDate
|
{ txDate = trDate
|
||||||
, txDescr = trDesc
|
, txDesc = trDesc
|
||||||
, txCommit = ()
|
, txCommit = ()
|
||||||
, txPrimary =
|
, txPrimary =
|
||||||
Left $
|
Left $
|
||||||
|
@ -312,12 +331,11 @@ toTx
|
||||||
, esTo = t
|
, esTo = t
|
||||||
}
|
}
|
||||||
, txOther = Left <$> ss
|
, txOther = Left <$> ss
|
||||||
, txBudget = historyName
|
|
||||||
, txPriority = priority
|
, txPriority = priority
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
curRes = do
|
curRes = do
|
||||||
m <- asks csCurrencyMap
|
m <- asks tsCurrencyMap
|
||||||
cur <- liftInner $ resolveCurrency m r tgCurrency
|
cur <- liftInner $ resolveCurrency m r tgCurrency
|
||||||
let prec = cpPrec cur
|
let prec = cpPrec cur
|
||||||
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
||||||
|
@ -331,7 +349,7 @@ resolveSubGetter
|
||||||
-> TxSubGetter
|
-> TxSubGetter
|
||||||
-> AppExceptT m SecondayEntrySet
|
-> AppExceptT m SecondayEntrySet
|
||||||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||||
m <- asks csCurrencyMap
|
m <- asks tsCurrencyMap
|
||||||
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
||||||
let prec = cpPrec cur
|
let prec = cpPrec cur
|
||||||
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
||||||
|
@ -510,6 +528,3 @@ parseDecimal (pat, re) s = case matchGroupsMaybe s re of
|
||||||
w <- readT "whole number" x
|
w <- readT "whole number" x
|
||||||
k <- readSign sign
|
k <- readSign sign
|
||||||
return (k, w)
|
return (k, w)
|
||||||
|
|
||||||
historyName :: BudgetName
|
|
||||||
historyName = BudgetName "history"
|
|
||||||
|
|
|
@ -57,8 +57,8 @@ AccountPathR sql=account_paths
|
||||||
TransactionR sql=transactions
|
TransactionR sql=transactions
|
||||||
commit CommitRId
|
commit CommitRId
|
||||||
date Day
|
date Day
|
||||||
description TxDesc
|
|
||||||
budgetName BudgetName
|
budgetName BudgetName
|
||||||
|
description TxDesc
|
||||||
priority Int
|
priority Int
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
EntrySetR sql=entry_sets
|
EntrySetR sql=entry_sets
|
||||||
|
|
|
@ -26,32 +26,51 @@ import Text.Regex.TDFA
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- database cache types
|
-- database cache types
|
||||||
|
|
||||||
type MonadFinance = MonadReader ConfigState
|
type MonadFinance = MonadReader TxState
|
||||||
|
|
||||||
data DeleteTxs = DeleteTxs
|
data DeleteTxs = DeleteTxs
|
||||||
{ dtTxs :: ![TransactionRId]
|
{ dtCommits :: ![CommitRId]
|
||||||
|
, dtTxs :: ![TransactionRId]
|
||||||
, dtEntrySets :: ![EntrySetRId]
|
, dtEntrySets :: ![EntrySetRId]
|
||||||
, dtEntries :: ![EntryRId]
|
, dtEntries :: ![EntryRId]
|
||||||
, dtTagRelations :: ![TagRelationRId]
|
, dtTagRelations :: ![TagRelationRId]
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
type CDOps c d = CRUDOps [c] () () [d]
|
type EntityCRUDOps r = CRUDOps [Entity r] () () [Key r]
|
||||||
|
|
||||||
-- TODO split the entry stuff from the account metadata stuff
|
data MetaCRUD = MetaCRUD
|
||||||
data ConfigState = ConfigState
|
{ mcCurrencies :: !(EntityCRUDOps CurrencyR)
|
||||||
{ csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
|
, mcAccounts :: !(EntityCRUDOps AccountR)
|
||||||
, csAccounts :: !(CDOps (Entity AccountR) AccountRId)
|
, mcPaths :: !(EntityCRUDOps AccountPathR)
|
||||||
, csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
|
, mcTags :: !(EntityCRUDOps TagR)
|
||||||
, csTags :: !(CDOps (Entity TagR) TagRId)
|
, mcBudgetScope :: !BudgetSpan
|
||||||
, csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
|
, mcHistoryScope :: !HistorySpan
|
||||||
, csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
|
}
|
||||||
, csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
|
|
||||||
, csAccountMap :: !AccountMap
|
type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs
|
||||||
, csCurrencyMap :: !CurrencyMap
|
|
||||||
, csTagMap :: !TagMap
|
type PreBudgetCRUD = BudgetCRUDOps Budget
|
||||||
, csBudgetScope :: !BudgetSpan
|
|
||||||
, csHistoryScope :: !HistorySpan
|
type FinalBudgetCRUD = BudgetCRUDOps (BudgetName, [Tx CommitR])
|
||||||
|
|
||||||
|
type HistoryCRUDOps h =
|
||||||
|
CRUDOps
|
||||||
|
h
|
||||||
|
[ReadEntry]
|
||||||
|
[Either TotalUpdateEntrySet FullUpdateEntrySet]
|
||||||
|
DeleteTxs
|
||||||
|
|
||||||
|
type PreHistoryCRUD = HistoryCRUDOps ([PairedTransfer], [Statement])
|
||||||
|
|
||||||
|
type FinalHistoryCRUD = HistoryCRUDOps [Tx CommitR]
|
||||||
|
|
||||||
|
data TxState = TxState
|
||||||
|
{ tsAccountMap :: !AccountMap
|
||||||
|
, tsCurrencyMap :: !CurrencyMap
|
||||||
|
, tsTagMap :: !TagMap
|
||||||
|
, tsBudgetScope :: !BudgetSpan
|
||||||
|
, tsHistoryScope :: !HistorySpan
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
@ -83,13 +102,14 @@ data CachedEntry
|
||||||
| CachedBalance Decimal
|
| CachedBalance Decimal
|
||||||
| CachedPercent Double
|
| CachedPercent Double
|
||||||
|
|
||||||
|
-- TODO this should actually be a ReadTx since it will be compared with other
|
||||||
|
-- Tx's to get the insert/update order correct
|
||||||
data ReadEntry = ReadEntry
|
data ReadEntry = ReadEntry
|
||||||
{ reCurrency :: !CurrencyRId
|
{ reCurrency :: !CurrencyRId
|
||||||
, reAcnt :: !AccountRId
|
, reAcnt :: !AccountRId
|
||||||
, reValue :: !Decimal
|
, reValue :: !Decimal
|
||||||
, reDate :: !Day
|
, reDate :: !Day
|
||||||
, rePriority :: !Int
|
, rePriority :: !Int
|
||||||
, reBudget :: !BudgetName
|
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
@ -131,7 +151,6 @@ data UpdateEntrySet f t = UpdateEntrySet
|
||||||
, utCurrency :: !CurrencyRId
|
, utCurrency :: !CurrencyRId
|
||||||
, utDate :: !Day
|
, utDate :: !Day
|
||||||
, utTotalValue :: !t
|
, utTotalValue :: !t
|
||||||
, utBudget :: !BudgetName
|
|
||||||
, utPriority :: !Int
|
, utPriority :: !Int
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
@ -196,13 +215,12 @@ data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
data Tx k = Tx
|
data Tx k = Tx
|
||||||
{ txDescr :: !TxDesc
|
{ txDesc :: !TxDesc
|
||||||
, txDate :: !Day
|
, txDate :: !Day
|
||||||
, txPriority :: !Int
|
, txPriority :: !Int
|
||||||
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
|
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
|
||||||
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
|
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
|
||||||
, txCommit :: !k
|
, txCommit :: !k
|
||||||
, txBudget :: !BudgetName
|
|
||||||
}
|
}
|
||||||
deriving (Generic, Show)
|
deriving (Generic, Show)
|
||||||
|
|
||||||
|
@ -218,12 +236,11 @@ data InsertEntrySet = InsertEntrySet
|
||||||
}
|
}
|
||||||
|
|
||||||
data InsertTx = InsertTx
|
data InsertTx = InsertTx
|
||||||
{ itxDescr :: !TxDesc
|
{ itxDesc :: !TxDesc
|
||||||
, itxDate :: !Day
|
, itxDate :: !Day
|
||||||
, itxPriority :: !Int
|
, itxPriority :: !Int
|
||||||
, itxEntrySets :: !(NonEmpty InsertEntrySet)
|
, itxEntrySets :: !(NonEmpty InsertEntrySet)
|
||||||
, itxCommit :: !CommitR
|
, itxCommit :: !CommitR
|
||||||
, itxBudget :: !BudgetName
|
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
|
|
|
@ -151,7 +151,7 @@ askDays
|
||||||
-> Maybe Interval
|
-> Maybe Interval
|
||||||
-> m [Day]
|
-> m [Day]
|
||||||
askDays dp i = do
|
askDays dp i = do
|
||||||
globalSpan <- asks (unBSpan . csBudgetScope)
|
globalSpan <- asks (unBSpan . tsBudgetScope)
|
||||||
case i of
|
case i of
|
||||||
Just i' -> do
|
Just i' -> do
|
||||||
localSpan <- liftExcept $ resolveDaySpan i'
|
localSpan <- liftExcept $ resolveDaySpan i'
|
||||||
|
@ -599,7 +599,7 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
||||||
uncurry3 f (a, b, c) = f a b c
|
uncurry3 f (a, b, c) = f a b c
|
||||||
|
|
||||||
lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
|
lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
|
||||||
lookupAccount = lookupFinance AcntField csAccountMap
|
lookupAccount = lookupFinance AcntField tsAccountMap
|
||||||
|
|
||||||
lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
|
lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
|
||||||
lookupAccountKey = fmap fst . lookupAccount
|
lookupAccountKey = fmap fst . lookupAccount
|
||||||
|
@ -608,7 +608,7 @@ lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
|
||||||
lookupAccountType = fmap snd . lookupAccount
|
lookupAccountType = fmap snd . lookupAccount
|
||||||
|
|
||||||
lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
|
lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
|
||||||
lookupCurrency = lookupFinance CurField csCurrencyMap
|
lookupCurrency = lookupFinance CurField tsCurrencyMap
|
||||||
|
|
||||||
lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
|
lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
|
||||||
lookupCurrencyKey = fmap cpID . lookupCurrency
|
lookupCurrencyKey = fmap cpID . lookupCurrency
|
||||||
|
@ -617,12 +617,12 @@ lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
|
||||||
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
||||||
|
|
||||||
lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
|
lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
|
||||||
lookupTag = lookupFinance TagField csTagMap
|
lookupTag = lookupFinance TagField tsTagMap
|
||||||
|
|
||||||
lookupFinance
|
lookupFinance
|
||||||
:: (MonadAppError m, MonadFinance m, Ord k, Show k)
|
:: (MonadAppError m, MonadFinance m, Ord k, Show k)
|
||||||
=> EntryIDType
|
=> EntryIDType
|
||||||
-> (ConfigState -> M.Map k a)
|
-> (TxState -> M.Map k a)
|
||||||
-> k
|
-> k
|
||||||
-> m a
|
-> m a
|
||||||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
|
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
|
||||||
|
@ -639,29 +639,28 @@ balanceTxs ebs =
|
||||||
fmap (Just . Left) $
|
fmap (Just . Left) $
|
||||||
liftInnerS $
|
liftInnerS $
|
||||||
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
|
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
|
||||||
go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
|
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
|
||||||
modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
|
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
||||||
return Nothing
|
return Nothing
|
||||||
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
|
go (ToInsert Tx {txPrimary, txOther, txDesc, txCommit, txDate, txPriority}) = do
|
||||||
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
|
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
|
||||||
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
|
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
|
||||||
es <- mapErrors (goOther tot) txOther
|
es <- mapErrors (goOther tot) txOther
|
||||||
let tx =
|
let tx =
|
||||||
-- TODO this is lame
|
-- TODO this is lame
|
||||||
InsertTx
|
InsertTx
|
||||||
{ itxDescr = txDescr
|
{ itxDesc = txDesc
|
||||||
, itxDate = txDate
|
, itxDate = txDate
|
||||||
, itxEntrySets = e :| es
|
, itxEntrySets = e :| es
|
||||||
, itxCommit = txCommit
|
, itxCommit = txCommit
|
||||||
, itxBudget = txBudget
|
|
||||||
, itxPriority = txPriority
|
, itxPriority = txPriority
|
||||||
}
|
}
|
||||||
return $ Just $ Right tx
|
return $ Just $ Right tx
|
||||||
where
|
where
|
||||||
goOther tot =
|
goOther tot =
|
||||||
either
|
either
|
||||||
(balanceSecondaryEntrySet txBudget)
|
balanceSecondaryEntrySet
|
||||||
(balancePrimaryEntrySet txBudget . fromShadow tot)
|
(balancePrimaryEntrySet . fromShadow tot)
|
||||||
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
|
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
|
||||||
|
|
||||||
binDate :: EntryCRU -> (Day, Int)
|
binDate :: EntryCRU -> (Day, Int)
|
||||||
|
@ -671,7 +670,7 @@ binDate (ToUpdate u) = either go go u
|
||||||
where
|
where
|
||||||
go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
|
go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
|
||||||
|
|
||||||
type BCKey = (CurrencyRId, BudgetName)
|
type BCKey = CurrencyRId
|
||||||
|
|
||||||
type ABCKey = (AccountRId, BCKey)
|
type ABCKey = (AccountRId, BCKey)
|
||||||
|
|
||||||
|
@ -692,7 +691,6 @@ rebalanceTotalEntrySet
|
||||||
, utToRO
|
, utToRO
|
||||||
, utCurrency
|
, utCurrency
|
||||||
, utTotalValue
|
, utTotalValue
|
||||||
, utBudget
|
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
|
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
|
||||||
|
@ -702,7 +700,7 @@ rebalanceTotalEntrySet
|
||||||
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
|
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
|
||||||
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
|
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
|
||||||
where
|
where
|
||||||
bc = (utCurrency, utBudget)
|
bc = utCurrency
|
||||||
|
|
||||||
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
|
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||||
rebalanceFullEntrySet
|
rebalanceFullEntrySet
|
||||||
|
@ -714,7 +712,6 @@ rebalanceFullEntrySet
|
||||||
, utFromRO
|
, utFromRO
|
||||||
, utToRO
|
, utToRO
|
||||||
, utCurrency
|
, utCurrency
|
||||||
, utBudget
|
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
|
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
|
||||||
|
@ -724,7 +721,7 @@ rebalanceFullEntrySet
|
||||||
(rs, ls) = case utFrom0 of
|
(rs, ls) = case utFrom0 of
|
||||||
Left x -> (x : utFromRO, utFromUnk)
|
Left x -> (x : utFromRO, utFromUnk)
|
||||||
Right x -> (utFromRO, x : utFromUnk)
|
Right x -> (utFromRO, x : utFromUnk)
|
||||||
bc = (utCurrency, utBudget)
|
bc = utCurrency
|
||||||
|
|
||||||
rebalanceDebit
|
rebalanceDebit
|
||||||
:: BCKey
|
:: BCKey
|
||||||
|
@ -806,11 +803,9 @@ updateUnknown k e = do
|
||||||
|
|
||||||
balancePrimaryEntrySet
|
balancePrimaryEntrySet
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> BudgetName
|
=> PrimaryEntrySet
|
||||||
-> PrimaryEntrySet
|
|
||||||
-> StateT EntryBals m InsertEntrySet
|
-> StateT EntryBals m InsertEntrySet
|
||||||
balancePrimaryEntrySet
|
balancePrimaryEntrySet
|
||||||
budgetName
|
|
||||||
EntrySet
|
EntrySet
|
||||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||||
|
@ -822,7 +817,7 @@ balancePrimaryEntrySet
|
||||||
let t0res = resolveAcntAndTags t0
|
let t0res = resolveAcntAndTags t0
|
||||||
let fsres = mapErrors resolveAcntAndTags fs
|
let fsres = mapErrors resolveAcntAndTags fs
|
||||||
let tsres = mapErrors resolveAcntAndTags ts
|
let tsres = mapErrors resolveAcntAndTags ts
|
||||||
let bc = (esCurrency, budgetName)
|
let bc = esCurrency
|
||||||
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
|
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
|
||||||
\(f0', fs') (t0', ts') -> do
|
\(f0', fs') (t0', ts') -> do
|
||||||
let balFrom = fmap liftInnerS . balanceDeferred
|
let balFrom = fmap liftInnerS . balanceDeferred
|
||||||
|
@ -831,11 +826,9 @@ balancePrimaryEntrySet
|
||||||
|
|
||||||
balanceSecondaryEntrySet
|
balanceSecondaryEntrySet
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> BudgetName
|
=> SecondayEntrySet
|
||||||
-> SecondayEntrySet
|
|
||||||
-> StateT EntryBals m InsertEntrySet
|
-> StateT EntryBals m InsertEntrySet
|
||||||
balanceSecondaryEntrySet
|
balanceSecondaryEntrySet
|
||||||
budgetName
|
|
||||||
EntrySet
|
EntrySet
|
||||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||||
|
@ -852,7 +845,7 @@ balanceSecondaryEntrySet
|
||||||
where
|
where
|
||||||
entrySum = sum . fmap (eValue . ieEntry)
|
entrySum = sum . fmap (eValue . ieEntry)
|
||||||
balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
|
balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
|
||||||
bc = (esCurrency, budgetName)
|
bc = esCurrency
|
||||||
|
|
||||||
balanceFinal
|
balanceFinal
|
||||||
:: (MonadAppError m)
|
:: (MonadAppError m)
|
||||||
|
@ -862,10 +855,10 @@ balanceFinal
|
||||||
-> Entry AccountRId () TagRId
|
-> Entry AccountRId () TagRId
|
||||||
-> [Entry AccountRId EntryLink TagRId]
|
-> [Entry AccountRId EntryLink TagRId]
|
||||||
-> StateT EntryBals m InsertEntrySet
|
-> StateT EntryBals m InsertEntrySet
|
||||||
balanceFinal k@(curID, _) tot fs t0 ts = do
|
balanceFinal curID tot fs t0 ts = do
|
||||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
|
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
|
||||||
let balTo = balanceLinked fv
|
let balTo = balanceLinked fv
|
||||||
ts' <- balanceTotalEntrySet balTo k tot t0 ts
|
ts' <- balanceTotalEntrySet balTo curID tot t0 ts
|
||||||
return $
|
return $
|
||||||
InsertEntrySet
|
InsertEntrySet
|
||||||
{ iesCurrency = curID
|
{ iesCurrency = curID
|
||||||
|
@ -963,20 +956,18 @@ findBalance k e = do
|
||||||
expandTransfers
|
expandTransfers
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> CommitR
|
=> CommitR
|
||||||
-> BudgetName
|
|
||||||
-> DaySpan
|
-> DaySpan
|
||||||
-> [PairedTransfer]
|
-> [PairedTransfer]
|
||||||
-> m [Tx CommitR]
|
-> m [Tx CommitR]
|
||||||
expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
|
expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
|
||||||
|
|
||||||
expandTransfer
|
expandTransfer
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> CommitR
|
=> CommitR
|
||||||
-> BudgetName
|
|
||||||
-> DaySpan
|
-> DaySpan
|
||||||
-> PairedTransfer
|
-> PairedTransfer
|
||||||
-> m [Tx CommitR]
|
-> m [Tx CommitR]
|
||||||
expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||||
txs <- mapErrors go transAmounts
|
txs <- mapErrors go transAmounts
|
||||||
return $ concat txs
|
return $ concat txs
|
||||||
where
|
where
|
||||||
|
@ -1001,8 +992,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
|
||||||
, txDate = day
|
, txDate = day
|
||||||
, txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
|
, txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
|
||||||
, txOther = []
|
, txOther = []
|
||||||
, txDescr = TxDesc desc
|
, txDesc = TxDesc desc
|
||||||
, txBudget = name
|
|
||||||
, txPriority = fromIntegral pri
|
, txPriority = fromIntegral pri
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue