From bd94afd30f8bcdc94d938a93a65c06fbbafe3a22 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 20 Jul 2023 00:25:33 -0400 Subject: [PATCH] FIX history updates --- app/Main.hs | 46 +--- lib/Internal/Budget.hs | 25 ++- lib/Internal/Database.hs | 397 ++++++++++++++++++++++----------- lib/Internal/History.hs | 43 ++-- lib/Internal/Types/Database.hs | 2 +- lib/Internal/Types/Main.hs | 63 ++++-- lib/Internal/Utils.hs | 58 ++--- 7 files changed, 380 insertions(+), 254 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 878fc5d..937ffad 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,18 +4,13 @@ module Main (main) where import Control.Concurrent import Control.Monad.Except -import Control.Monad.IO.Rerunnable import Control.Monad.Logger -import Control.Monad.Reader import Data.Bitraversable -- import Data.Hashable import qualified Data.Text.IO as TI import qualified Database.Esqueleto.Experimental as E -import Database.Persist.Monad import qualified Dhall hiding (double, record) -import Internal.Budget import Internal.Database -import Internal.History import Internal.Types.Main import Internal.Utils import Options.Applicative @@ -72,7 +67,7 @@ options = <|> getConf dumpCurrencies <|> getConf dumpAccounts <|> getConf dumpAccountKeys - <|> getConf sync + <|> getConf sync_ where getConf m = Options <$> configFile <*> m @@ -113,8 +108,8 @@ dumpAccountKeys = <> help "Dump all account keys/aliases" ) -sync :: Parser Mode -sync = +sync_ :: Parser Mode +sync_ = flag' Sync ( long "sync" @@ -219,40 +214,7 @@ runSync threads c bs hs = do pool <- runNoLoggingT $ mkPool $ sqlConfig config putStrLn "doing other stuff" setNumCapabilities 1 - handle err $ do - -- _ <- 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 + handle err $ sync pool root config bs' hs' where root = takeDirectory c err (AppException es) = do diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 682dae7..c46636d 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -1,4 +1,4 @@ -module Internal.Budget (readBudget) where +module Internal.Budget (readBudgetCRUD) where import Control.Monad.Except import Data.Decimal hiding (allocate) @@ -13,7 +13,12 @@ import qualified RIO.NonEmpty as NE import qualified RIO.Text as T 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 b@Budget { bgtLabel @@ -27,12 +32,12 @@ readBudget } = do spanRes <- getSpan - case spanRes of + (bgtLabel,) <$> case spanRes of Nothing -> return [] Just budgetSpan -> do (intAllos, _) <- combineError intAlloRes acntRes (,) - let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes - let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers + let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes + let res2 = expandTransfers c budgetSpan bgtTransfers txs <- combineError (concat <$> res1) res2 (++) shadow <- addShadowTransfers bgtShadowTransfers txs return $ txs ++ shadow @@ -49,7 +54,7 @@ readBudget ++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtPosttax) getSpan = do - globalSpan <- asks (unBSpan . csBudgetScope) + globalSpan <- asks (unBSpan . tsBudgetScope) case bgtInterval of Nothing -> return $ Just globalSpan Just bi -> do @@ -78,14 +83,12 @@ sortAllo a@Allocation {alloAmts = as} = do readIncome :: (MonadAppError m, MonadFinance m) => CommitR - -> BudgetName -> IntAllocations -> DaySpan -> Income -> m [Tx CommitR] readIncome key - name (intPre, intTax, intPost) ds Income @@ -154,9 +157,9 @@ readIncome , txDate = day , txPrimary = Left primary , txOther = [] - , txDescr = TxDesc "" - , txBudget = name - , txPriority = incPriority + , txDesc = TxDesc "" + , -- , txBudget = name + txPriority = incPriority } periodScaler diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index bb3d737..78972a6 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE ImplicitPrelude #-} + module Internal.Database ( runDB - , readConfigState + , readDB , nukeTables - , updateDBState + , updateMeta + -- , updateDBState , tree2Records , flattenAcntRoot , indexAcntRoot @@ -10,13 +13,14 @@ module Internal.Database , mkPool , insertEntry , readUpdates - , insertAll , updateTx + , sync ) where import Conduit import Control.Monad.Except +import Control.Monad.IO.Rerunnable import Control.Monad.Logger import Data.Decimal 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.Utils 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.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 :: MonadUnliftIO m => SqlConfig @@ -106,58 +158,116 @@ nukeTables = do -- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name] -- toBal = maybe "???" (fmtRational 2) . unValue -readConfigState +readDB :: (MonadAppError m, MonadSqlQuery m) => Config -> [Budget] -> [History] - -> m ConfigState -readConfigState c bs hs = do - (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts - (pathsIns, _, pathsDel) <- diff newPaths - (curs2Ins, cursRem, curs2Del) <- diff newCurs - (tags2Ins, tagsRem, tags2Del) <- diff newTags - 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) - + -> m (MetaCRUD, TxState, PreBudgetCRUD, PreHistoryCRUD) +readDB c bs hs = do + curAcnts <- readCurrentIds + curPaths <- readCurrentIds + curCurs <- readCurrentIds + curTags <- readCurrentIds (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 hsRes = HistorySpan <$> resolveScope statementInterval 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 - bgt <- makeTxCRUD existing bs curBgts bChanged - hTrans <- makeTxCRUD existing ts curHistTrs hChanged - hStmt <- makeTxCRUD existing ss curHistSts hChanged - - 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 - } + budgets <- makeBudgetCRUD existing bs curBgts bChanged + history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged + return (meta, txS, budgets, history) where (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 newTags = tag2Record <$> tags c newCurs = currency2Record <$> currencies 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 :: (MonadAppError m, MonadSqlQuery m) @@ -175,37 +285,6 @@ readScopeChanged dbempty bscope hscope = do return (bscope /= b, hscope /= h) _ -> 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 cs = do xs <- selectE $ do @@ -218,33 +297,29 @@ readTxIds cs = do `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction) `E.innerJoin` E.table `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset) - `E.innerJoin` E.table - `E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry) + `E.leftJoin` E.table + `E.on` (\(_ :& _ :& _ :& e :& t) -> E.just (e ^. EntryRId) ==. t ?. TagRelationREntry) E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs return - ( txs ^. TransactionRId + ( commits ^. CommitRId + , txs ^. TransactionRId , ess ^. EntrySetRId , es ^. EntryRId - , ts ^. TagRelationRId + , ts ?. TagRelationRId ) - let (txs, ss, es, ts) = L.unzip4 xs + let (cms, txs, ss, es, ts) = L.unzip5 xs return $ DeleteTxs - { dtTxs = go txs + { dtCommits = go cms + , dtTxs = go txs , dtEntrySets = go ss , dtEntries = go es - , dtTagRelations = E.unValue <$> ts + , dtTagRelations = catMaybes $ E.unValue <$> ts } where go :: Eq a => [E.Value a] -> [a] 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 = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) @@ -255,7 +330,7 @@ currency2Record :: Currency -> Entity CurrencyR currency2Record c@Currency {curSymbol, curFullname, 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 rs <- E.from E.table return (rs ^. E.persistIdField) @@ -263,8 +338,8 @@ readCurrentIds = fmap (E.unValue <$>) $ selectE $ do readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash]) readCurrentCommits = do xs <- selectE $ do - rs <- E.from E.table - return (rs ^. CommitRHash, rs ^. CommitRType) + commits <- E.from E.table + return (commits ^. CommitRHash, commits ^. CommitRType) return $ foldr go ([], [], []) xs where go (x, t) (bs, ts, hs) = @@ -387,39 +462,54 @@ indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . fl updateCD :: ( MonadSqlQuery m , PersistRecordBackend a SqlBackend - , PersistRecordBackend b SqlBackend ) - => CDOps (Entity a) (Key b) + => EntityCRUDOps a -> m () updateCD (CRUDOps cs () () ds) = do mapM_ deleteKeyE ds insertEntityManyE cs deleteTxs :: MonadSqlQuery m => DeleteTxs -> m () -deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do - mapM_ deleteKeyE dtTxs - mapM_ deleteKeyE dtEntrySets - mapM_ deleteKeyE dtEntries +deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do mapM_ deleteKeyE dtTagRelations + mapM_ deleteKeyE dtEntries + mapM_ deleteKeyE dtEntrySets + mapM_ deleteKeyE dtTxs + mapM_ deleteKeyE dtCommits -updateDBState :: (MonadFinance m, MonadSqlQuery m) => m () -updateDBState = do - updateCD =<< asks csCurrencies - updateCD =<< asks csAccounts - updateCD =<< asks csPaths - updateCD =<< asks csTags - deleteTxs =<< asks (coDelete . csBudgets) - deleteTxs =<< asks (coDelete . csHistTrans) - deleteTxs =<< asks (coDelete . csHistStmts) - b <- asks csBudgetScope - h <- asks csHistoryScope - repsertE (E.toSqlKey 1) $ ConfigStateR h b +-- updateDBState :: (MonadFinance m, MonadSqlQuery m) => m () +-- updateDBState = do +-- updateCD =<< asks csCurrencies +-- updateCD =<< asks csAccounts +-- updateCD =<< asks csPaths +-- updateCD =<< asks csTags +-- -- deleteTxs =<< asks (coDelete . csBudgets) +-- -- deleteTxs =<< asks (coDelete . csHistory) +-- b <- asks csBudgetScope +-- h <- asks csHistoryScope +-- 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 :: MonadSqlQuery m => ExistingConfig -> [(CommitHash, a)] - -> m ([CommitHash], [(CommitHash, a)]) + -> m ([(CommitHash, a)], [CommitHash]) readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do rs <- selectE $ do (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 as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs] - let valid = (cs `S.intersection` as) `S.intersection` ts - let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs - return (a0, []) + let invalid = (cs `S.union` as) `S.union` ts + return $ second (fst <$>) $ L.partition ((`S.member` invalid) . fst) xs where go existing = S.fromList . fmap (E.unValue . fst) - . L.filter (all (`S.member` existing) . snd) + . L.filter (not . all (`S.member` existing) . snd) . groupKey id readUpdates @@ -478,7 +567,6 @@ readUpdates hashes = do ( ( entrysets ^. EntrySetRId , txs ^. TransactionRDate - , txs ^. TransactionRBudgetName , txs ^. TransactionRPriority , ( entrysets ^. EntrySetRCurrency @@ -489,11 +577,11 @@ readUpdates hashes = do ) ) 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 return (toRead', toUpdate') where - makeUES ((_, day, name, pri, (curID, prec)), es) = do + makeUES ((_, day, pri, (curID, prec)), es) = do let prec' = fromIntegral $ E.unValue prec let cur = E.unValue curID let res = @@ -520,7 +608,6 @@ readUpdates hashes = do , utFromUnk = fromUnk , utToUnk = toUnk , utTotalValue = realFracToDecimalP prec' tot - , utBudget = E.unValue name , utPriority = E.unValue pri } Right x -> @@ -535,19 +622,17 @@ readUpdates hashes = do , utFromUnk = fromUnk , utToUnk = toUnk , utTotalValue = () - , utBudget = E.unValue name , utPriority = E.unValue pri } -- TODO this error is lame - _ -> throwAppError $ DBError $ DBUpdateUnbalanced - makeRE ((_, day, name, pri, (curID, prec)), entry) = do + _ -> throwAppError $ DBError DBUpdateUnbalanced + makeRE ((_, day, pri, (curID, prec)), entry) = do let e = entityVal entry in ReadEntry { reDate = E.unValue day , reCurrency = E.unValue curID , reAcnt = entryRAccount e , reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e) - , reBudget = E.unValue name , 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 (Just v, Nothing) -> err $ DBLinkInvalidValue v False (Just v, Just TFixed) -> err $ DBLinkInvalidValue v True - (Nothing, Just TBalance) -> err $ DBLinkInvalidBalance - (Nothing, Just TPercent) -> err $ DBLinkInvalidPercent + (Nothing, Just TBalance) -> err DBLinkInvalidBalance + (Nothing, Just TPercent) -> err DBLinkInvalidPercent where go = return . Right . Right err = throwAppError . DBError . DBLinkError k @@ -680,21 +765,72 @@ makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRVal makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId () 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) - => [EntryCRU] + => FinalBudgetCRUD -> m () -insertAll ebs = do - (toUpdate, toInsert) <- balanceTxs ebs +insertBudgets (CRUDOps bs () () ds) = do + 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 forM_ (groupWith itxCommit toInsert) $ \(c, ts) -> do ck <- insert c - mapM_ (insertTx ck) ts + mapM_ (insertTx historyName ck) ts + deleteTxs ds -insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () -insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do - k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority +-- insertAll +-- :: (MonadAppError m, MonadSqlQuery m, MonadFinance m) +-- => 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) where 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 q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q) + +historyName :: BudgetName +historyName = BudgetName "history" diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index fcc8b0a..aefdb08 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -2,6 +2,7 @@ module Internal.History ( readHistStmt , readHistTransfer , splitHistory + , readHistoryCRUD ) where @@ -24,6 +25,20 @@ import qualified RIO.Vector as V import Text.Regex.TDFA hiding (matchAll) 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 -- the IO monad, and thus will throw IO errors rather than using the ExceptT -- thingy @@ -41,8 +56,8 @@ readHistTransfer => PairedTransfer -> m [Tx CommitR] readHistTransfer ht = do - bounds <- asks (unHSpan . csHistoryScope) - expandTransfer c historyName bounds ht + bounds <- asks (unHSpan . tsHistoryScope) + expandTransfer c bounds ht where c = CommitR (CommitHash $ hash ht) CTHistoryTransfer @@ -53,23 +68,27 @@ readHistStmt :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement - -> m [Tx CommitR] + -> m (Either AppException [Tx CommitR]) readHistStmt root i = do + bounds <- asks (unHSpan . tsHistoryScope) 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 c = CommitR (CommitHash $ hash i) CTHistoryStatement -- 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 let ores = compileOptions stmtTxOpts let cres = combineErrors $ compileMatch <$> stmtParsers (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,) let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions records <- L.sort . concat <$> mapErrorsIO readStmt paths - fromEither =<< runExceptT (matchRecords compiledMatches records) + runExceptT (matchRecords compiledMatches records) where paths = (root ) <$> stmtPaths @@ -301,7 +320,7 @@ toTx combineError curRes subRes $ \(cur, f, t) ss -> Tx { txDate = trDate - , txDescr = trDesc + , txDesc = trDesc , txCommit = () , txPrimary = Left $ @@ -312,12 +331,11 @@ toTx , esTo = t } , txOther = Left <$> ss - , txBudget = historyName , txPriority = priority } where curRes = do - m <- asks csCurrencyMap + m <- asks tsCurrencyMap cur <- liftInner $ resolveCurrency m r tgCurrency let prec = cpPrec cur let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom @@ -331,7 +349,7 @@ resolveSubGetter -> TxSubGetter -> AppExceptT m SecondayEntrySet resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do - m <- asks csCurrencyMap + m <- asks tsCurrencyMap cur <- liftInner $ resolveCurrency m r tsgCurrency let prec = cpPrec cur 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 k <- readSign sign return (k, w) - -historyName :: BudgetName -historyName = BudgetName "history" diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index f85efbc..e7509f6 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -57,8 +57,8 @@ AccountPathR sql=account_paths TransactionR sql=transactions commit CommitRId date Day - description TxDesc budgetName BudgetName + description TxDesc priority Int deriving Show Eq EntrySetR sql=entry_sets diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 3079e4e..f56f67a 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -26,32 +26,51 @@ import Text.Regex.TDFA -------------------------------------------------------------------------------- -- database cache types -type MonadFinance = MonadReader ConfigState +type MonadFinance = MonadReader TxState data DeleteTxs = DeleteTxs - { dtTxs :: ![TransactionRId] + { dtCommits :: ![CommitRId] + , dtTxs :: ![TransactionRId] , dtEntrySets :: ![EntrySetRId] , dtEntries :: ![EntryRId] , dtTagRelations :: ![TagRelationRId] } 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 ConfigState = ConfigState - { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId) - , csAccounts :: !(CDOps (Entity AccountR) AccountRId) - , csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId) - , csTags :: !(CDOps (Entity TagR) TagRId) - , csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs) - , csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs) - , csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs) - , csAccountMap :: !AccountMap - , csCurrencyMap :: !CurrencyMap - , csTagMap :: !TagMap - , csBudgetScope :: !BudgetSpan - , csHistoryScope :: !HistorySpan +data MetaCRUD = MetaCRUD + { mcCurrencies :: !(EntityCRUDOps CurrencyR) + , mcAccounts :: !(EntityCRUDOps AccountR) + , mcPaths :: !(EntityCRUDOps AccountPathR) + , mcTags :: !(EntityCRUDOps TagR) + , mcBudgetScope :: !BudgetSpan + , mcHistoryScope :: !HistorySpan + } + +type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs + +type PreBudgetCRUD = BudgetCRUDOps Budget + +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) @@ -83,13 +102,14 @@ data CachedEntry | CachedBalance Decimal | 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 { reCurrency :: !CurrencyRId , reAcnt :: !AccountRId , reValue :: !Decimal , reDate :: !Day , rePriority :: !Int - , reBudget :: !BudgetName } deriving (Show) @@ -131,7 +151,6 @@ data UpdateEntrySet f t = UpdateEntrySet , utCurrency :: !CurrencyRId , utDate :: !Day , utTotalValue :: !t - , utBudget :: !BudgetName , utPriority :: !Int } deriving (Show) @@ -196,13 +215,12 @@ data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord, Show) data Tx k = Tx - { txDescr :: !TxDesc + { txDesc :: !TxDesc , txDate :: !Day , txPriority :: !Int , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet) , txOther :: ![Either SecondayEntrySet ShadowEntrySet] , txCommit :: !k - , txBudget :: !BudgetName } deriving (Generic, Show) @@ -218,12 +236,11 @@ data InsertEntrySet = InsertEntrySet } data InsertTx = InsertTx - { itxDescr :: !TxDesc + { itxDesc :: !TxDesc , itxDate :: !Day , itxPriority :: !Int , itxEntrySets :: !(NonEmpty InsertEntrySet) , itxCommit :: !CommitR - , itxBudget :: !BudgetName } deriving (Generic) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 3acf795..dcaffe8 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -151,7 +151,7 @@ askDays -> Maybe Interval -> m [Day] askDays dp i = do - globalSpan <- asks (unBSpan . csBudgetScope) + globalSpan <- asks (unBSpan . tsBudgetScope) case i of Just i' -> do 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 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 = fmap fst . lookupAccount @@ -608,7 +608,7 @@ lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType lookupAccountType = fmap snd . lookupAccount 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 = fmap cpID . lookupCurrency @@ -617,12 +617,12 @@ lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision lookupCurrencyPrec = fmap cpPrec . lookupCurrency lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId -lookupTag = lookupFinance TagField csTagMap +lookupTag = lookupFinance TagField tsTagMap lookupFinance :: (MonadAppError m, MonadFinance m, Ord k, Show k) => EntryIDType - -> (ConfigState -> M.Map k a) + -> (TxState -> M.Map k a) -> k -> m a lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f @@ -639,29 +639,28 @@ balanceTxs ebs = fmap (Just . Left) $ liftInnerS $ either rebalanceTotalEntrySet rebalanceFullEntrySet utx - go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do - modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue + go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do + modify $ mapAdd_ (reAcnt, reCurrency) reValue return Nothing - go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do - e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary + go (ToInsert Tx {txPrimary, txOther, txDesc, txCommit, txDate, txPriority}) = do + e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e es <- mapErrors (goOther tot) txOther let tx = -- TODO this is lame InsertTx - { itxDescr = txDescr + { itxDesc = txDesc , itxDate = txDate , itxEntrySets = e :| es , itxCommit = txCommit - , itxBudget = txBudget , itxPriority = txPriority } return $ Just $ Right tx where goOther tot = either - (balanceSecondaryEntrySet txBudget) - (balancePrimaryEntrySet txBudget . fromShadow tot) + balanceSecondaryEntrySet + (balancePrimaryEntrySet . fromShadow tot) fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue} binDate :: EntryCRU -> (Day, Int) @@ -671,7 +670,7 @@ binDate (ToUpdate u) = either go go u where go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority) -type BCKey = (CurrencyRId, BudgetName) +type BCKey = CurrencyRId type ABCKey = (AccountRId, BCKey) @@ -692,7 +691,6 @@ rebalanceTotalEntrySet , utToRO , utCurrency , utTotalValue - , utBudget } = do (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk @@ -702,7 +700,7 @@ rebalanceTotalEntrySet ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked return (f0 {ueValue = StaticValue f0val} : fs ++ ts) where - bc = (utCurrency, utBudget) + bc = utCurrency rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced] rebalanceFullEntrySet @@ -714,7 +712,6 @@ rebalanceFullEntrySet , utFromRO , utToRO , utCurrency - , utBudget } = do (ftot, fs, tpairs) <- rebalanceDebit bc rs ls @@ -724,7 +721,7 @@ rebalanceFullEntrySet (rs, ls) = case utFrom0 of Left x -> (x : utFromRO, utFromUnk) Right x -> (utFromRO, x : utFromUnk) - bc = (utCurrency, utBudget) + bc = utCurrency rebalanceDebit :: BCKey @@ -806,11 +803,9 @@ updateUnknown k e = do balancePrimaryEntrySet :: (MonadAppError m, MonadFinance m) - => BudgetName - -> PrimaryEntrySet + => PrimaryEntrySet -> StateT EntryBals m InsertEntrySet balancePrimaryEntrySet - budgetName EntrySet { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} @@ -822,7 +817,7 @@ balancePrimaryEntrySet let t0res = resolveAcntAndTags t0 let fsres = mapErrors resolveAcntAndTags fs let tsres = mapErrors resolveAcntAndTags ts - let bc = (esCurrency, budgetName) + let bc = esCurrency combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $ \(f0', fs') (t0', ts') -> do let balFrom = fmap liftInnerS . balanceDeferred @@ -831,11 +826,9 @@ balancePrimaryEntrySet balanceSecondaryEntrySet :: (MonadAppError m, MonadFinance m) - => BudgetName - -> SecondayEntrySet + => SecondayEntrySet -> StateT EntryBals m InsertEntrySet balanceSecondaryEntrySet - budgetName EntrySet { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} @@ -852,7 +845,7 @@ balanceSecondaryEntrySet where entrySum = sum . fmap (eValue . ieEntry) balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc - bc = (esCurrency, budgetName) + bc = esCurrency balanceFinal :: (MonadAppError m) @@ -862,10 +855,10 @@ balanceFinal -> Entry AccountRId () TagRId -> [Entry AccountRId EntryLink TagRId] -> 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 balTo = balanceLinked fv - ts' <- balanceTotalEntrySet balTo k tot t0 ts + ts' <- balanceTotalEntrySet balTo curID tot t0 ts return $ InsertEntrySet { iesCurrency = curID @@ -963,20 +956,18 @@ findBalance k e = do expandTransfers :: (MonadAppError m, MonadFinance m) => CommitR - -> BudgetName -> DaySpan -> [PairedTransfer] -> m [Tx CommitR] -expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds) +expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds) expandTransfer :: (MonadAppError m, MonadFinance m) => CommitR - -> BudgetName -> DaySpan -> PairedTransfer -> 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 return $ concat txs where @@ -1001,8 +992,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr , txDate = day , txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v'' , txOther = [] - , txDescr = TxDesc desc - , txBudget = name + , txDesc = TxDesc desc , txPriority = fromIntegral pri }