From 4c46f035f5dd0a2de164840b041b3fb3ba9e90ea Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 13 Jul 2023 23:31:27 -0400 Subject: [PATCH] WIP use more robust update strategy --- app/Main.hs | 35 +- lib/Internal/Budget.hs | 47 +-- lib/Internal/Database.hs | 562 ++++++++++++++++++++++++--------- lib/Internal/History.hs | 24 +- lib/Internal/Types/Database.hs | 48 ++- lib/Internal/Types/Dhall.hs | 2 +- lib/Internal/Types/Main.hs | 87 ++--- lib/Internal/Utils.hs | 26 +- 8 files changed, 557 insertions(+), 274 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 87eb835..dc5d97f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,6 +9,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Data.Bitraversable 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 @@ -194,14 +195,13 @@ runDumpAccountKeys c = do ar <- accounts <$> readConfig c let ks = paths2IDs $ - fmap (double . fst) $ - concatMap (t3 . uncurry tree2Records) $ - flattenAcntRoot ar + fmap (double . accountRFullpath . E.entityVal) $ + fst $ + indexAcntRoot ar mapM_ (uncurry printPair) ks where printPair i p = do liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i] - t3 (_, _, x) = x double x = (x, x) runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO () @@ -221,27 +221,29 @@ runSync threads c bs hs = do -- _ <- askLoggerIO -- Get the current DB state. - (state, updates) <- runSqlQueryT pool $ do + state <- runSqlQueryT pool $ do runMigration migrateAll - liftIOExceptT $ getDBState config bs' hs' + 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. - (rus, is) <- + toIns <- flip runReaderT state $ do - let (hTs, hSs) = splitHistory hs' -- TODO for some mysterious reason using multithreading just for this -- little bit slows the program down by several seconds -- lift $ setNumCapabilities threads + (CRUDOps hSs _ _ _) <- askDBState csHistStmts hSs' <- mapErrorsIO (readHistStmt root) hSs -- lift $ setNumCapabilities 1 -- lift $ print $ length $ lefts hSs' -- lift $ print $ length $ rights hSs' + (CRUDOps hTs _ _ _) <- askDBState csHistTrans hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs -- lift $ print $ length $ lefts hTs' - bTs <- liftIOExceptT $ mapErrors readBudget bs' + (CRUDOps bTs _ _ _) <- askDBState csBudgets + bTs' <- liftIOExceptT $ mapErrors readBudget bTs -- lift $ print $ length $ lefts bTs - return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs + return $ concat $ hSs' ++ hTs' ++ bTs' -- print $ length $ kmNewCommits state -- print $ length $ duOldCommits updates -- print $ length $ duNewTagIds updates @@ -252,15 +254,12 @@ runSync threads c bs hs = do -- Update the DB. runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do -- NOTE this must come first (unless we defer foreign keys) - updateDBState updates - -- TODO skip this entire section if the database won't change (eg length - -- of 'is' is zero and there are no commits to delete) + updateDBState res <- runExceptT $ do - -- TODO taking out the hash is dumb - (rs, ues) <- readUpdates $ fmap commitRHash rus - -- rerunnableIO $ print ues - -- rerunnableIO $ print $ length rs - let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is + (CRUDOps _ bRs bUs _) <- askDBState csBudgets + (CRUDOps _ tRs tUs _) <- askDBState csHistTrans + (CRUDOps _ sRs sUs _) <- askDBState 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 diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index ad685f9..251701e 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -3,7 +3,7 @@ module Internal.Budget (readBudget) where import Control.Monad.Except import Data.Decimal hiding (allocate) import Data.Foldable -import Internal.Database +import Data.Hashable import Internal.Types.Main import Internal.Utils import RIO hiding (to) @@ -13,10 +13,7 @@ import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import RIO.Time -readBudget - :: (MonadInsertError m, MonadFinance m) - => Budget - -> m (Either CommitR [Tx CommitR]) +readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [Tx CommitR] readBudget b@Budget { bgtLabel @@ -28,18 +25,19 @@ readBudget , bgtPosttax , bgtInterval } = - eitherHash CTBudget b return $ \key -> do + do spanRes <- getSpan case spanRes of Nothing -> return [] Just budgetSpan -> do (intAllos, _) <- combineError intAlloRes acntRes (,) - let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes - let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers + let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes + let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers txs <- combineError (concat <$> res1) res2 (++) shadow <- addShadowTransfers bgtShadowTransfers txs return $ txs ++ shadow where + c = CommitR (hash b) CTBudget acntRes = mapErrors isNotIncomeAcnt alloAcnts intAlloRes = combineError3 pre_ tax_ post_ (,,) pre_ = sortAllos bgtPretax @@ -51,7 +49,7 @@ readBudget ++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtPosttax) getSpan = do - globalSpan <- askDBState kmBudgetInterval + globalSpan <- askDBState csBudgetScope case bgtInterval of Nothing -> return $ Just globalSpan Just bi -> do @@ -124,7 +122,7 @@ readIncome flatTax = concatMap flattenAllo incTaxes flatPost = concatMap flattenAllo incPosttax sumAllos = sum . fmap faValue - -- TODO ensure these are all the "correct" accounts + entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts} allocate cp gross prevDay day = do scaler <- liftExcept $ periodScaler pType' prevDay day let precision = cpPrec cp @@ -138,21 +136,8 @@ readIncome let post = allocatePost precision aftertaxGross $ flatPost ++ concatMap (selectAllos day) intPost - -- TODO double or rational here? - let src = - Entry - { eAcnt = srcAcnt - , eValue = () - , eComment = "" - , eTags = srcTags - } - let dest = - Entry - { eAcnt = destAcnt - , eValue = () - , eComment = "balance after deductions" - , eTags = destTags - } + let src = entry0 srcAcnt "gross income" srcTags + let dest = entry0 destAcnt "balance after deductions" destTags let allos = allo2Trans <$> (pre ++ tax ++ post) let primary = EntrySet @@ -357,11 +342,13 @@ fromShadow => Tx CommitR -> ShadowTransfer -> m (Maybe ShadowEntrySet) -fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do - cp <- lookupCurrency stCurrency - res <- liftExcept $ shadowMatches stMatch tx - let es = entryPair stFrom stTo (cpID cp) stDesc stRatio () - return $ if not res then Nothing else Just es +fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = + combineErrorM curRes shaRes $ \cur sha -> do + let es = entryPair stFrom stTo cur stDesc stRatio () + return $ if not sha then Nothing else Just es + where + curRes = lookupCurrencyKey stCurrency + shaRes = liftExcept $ shadowMatches stMatch tx shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 62ed6eb..83fe253 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -1,17 +1,15 @@ module Internal.Database ( runDB + , readConfigState , nukeTables , updateHashes , updateDBState , getDBState , tree2Records , flattenAcntRoot + , indexAcntRoot , paths2IDs , mkPool - , whenHash0 - , whenHash - , whenHash_ - , eitherHash , insertEntry , readUpdates , insertAll @@ -29,7 +27,8 @@ import qualified Database.Esqueleto.Experimental as E import Database.Esqueleto.Internal.Internal (SqlSelect) import Database.Persist.Monad import Database.Persist.Sqlite hiding - ( delete + ( Statement + , delete , deleteWhere , insert , insertKey @@ -43,10 +42,11 @@ import GHC.Err import Internal.Types.Main import Internal.Utils import RIO hiding (LogFunc, isNothing, on, (^.)) -import RIO.List ((\\)) +import qualified RIO.HashSet as HS import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.NonEmpty as NE +-- import qualified RIO.Set as S import qualified RIO.Text as T runDB @@ -109,6 +109,186 @@ nukeTables = do -- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name] -- toBal = maybe "???" (fmtRational 2) . unValue +-- data TxState = TxState +-- { tsBudget :: !(CRUDOps () () () ()) +-- , tsHistTransfer :: !(CRUDOps () () () ()) +-- , tsHistStatement :: !(CRUDOps () () () ()) +-- } + +-- readTxState :: (MonadFinance m, MonadUnliftIO m) -> [Budget] -> [History] -> m TxState +-- readTxState bs hs = do +-- (curBgts, curHistTrs, curHistSts) <- readCurrentCommits + +readConfigState + :: (MonadInsertError m, MonadSqlQuery m) + => Config + -> [Budget] + -> [History] + -> m ConfigState +readConfigState c bs hs = do + curAcnts <- readCurrentIds AccountRId + curTags <- readCurrentIds TagRId + curCurs <- readCurrentIds CurrencyRId + curPaths <- readCurrentIds AccountPathRId + let (acnts2Ins, acntsRem, acnts2Del) = diff newAcnts curAcnts + let (pathsIns, _, pathsDel) = diff newPaths curPaths + let (curs2Ins, cursRem, curs2Del) = diff newCurs curCurs + let (tags2Ins, tagsRem, tags2Del) = diff newTags curTags + let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem) + let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem) + let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem) + let fromMap f = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems + let existing = + ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap) + + (curBgts, curHistTrs, curHistSts) <- readCurrentCommits + (bChanged, hChanged) <- readScopeChanged $ scope c + bgt <- makeTxCRUD existing bs curBgts bChanged + hTrans <- makeTxCRUD existing ts curHistTrs hChanged + hStmt <- makeTxCRUD existing ss curHistSts hChanged + + let bsRes = resolveScope budgetInterval + let hsRes = resolveScope statementInterval + combineError bsRes hsRes $ \b h -> + 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 = b + , csHistoryScope = h + } + where + (ts, ss) = splitHistory hs + diff :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a]) + diff = setDiffWith (\a b -> E.entityKey a == b) + (newAcnts, newPaths) = indexAcntRoot $ accounts c + newTags = tag2Record <$> tags c + newCurs = currency2Record <$> currencies c + resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c + +readScopeChanged :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool) +readScopeChanged s = do + rs <- dumpTbl + case rs of + [] -> return (True, True) + [r] -> do + let (ConfigStateR hsh bsh) = E.entityVal r + return + ( hashScope budgetInterval == bsh + , hashScope statementInterval == hsh + ) + _ -> throwError undefined + where + hashScope f = hash $ f s + +makeTxCRUD + :: (MonadInsertError m, MonadSqlQuery m, Hashable a) + => ExistingConfig + -> [a] + -> [Int] + -> Bool + -> m + ( CRUDOps + [a] + [ReadEntry] + [Either TotalUpdateEntrySet FullUpdateEntrySet] + DeleteTxs + ) +makeTxCRUD existing newThings curThings scopeChanged = do + let (toDelHashes, overlap, toIns) = setDiffWith go 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 + (toInsRetry, noRetry) <- readInvalidIds existing overlap + let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry) + let toInsAll = (snd <$> toInsRetry) ++ toIns + -- 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 + where + go a b = hash b == a + +readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs +readTxIds cs = do + xs <- selectE $ do + (commits :& txs :& ess :& es :& ts) <- + E.from + $ E.table + `E.innerJoin` E.table + `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit) + `E.innerJoin` E.table + `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.where_ $ commits ^. CommitRHash `E.in_` E.valList cs + return + ( txs ^. TransactionRId + , ess ^. EntrySetRId + , es ^. EntryRId + , ts ^. TagRelationRId + ) + let (txs, ss, es, ts) = L.unzip4 xs + return $ + DeleteTxs + { dtTxs = go txs + , dtEntrySets = go ss + , dtEntries = go es + , dtTagRelations = 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)) + +tag2Record :: Tag -> Entity TagR +tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc + +currency2Record :: Currency -> Entity CurrencyR +currency2Record c@Currency {curSymbol, curFullname, curPrecision} = + Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) + +readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a] +readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do + rs <- E.from E.table + return (rs ^. f) + +readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int]) +readCurrentCommits = do + xs <- selectE $ do + rs <- E.from E.table + return (rs ^. CommitRHash, rs ^. CommitRType) + return $ foldr go ([], [], []) xs + where + go (x, t) (bs, ts, hs) = + let y = E.unValue x + in case E.unValue t of + CTBudget -> (y : bs, ts, hs) + CTTransfer -> (bs, y : ts, hs) + CTHistory -> (bs, ts, y : hs) + hashConfig :: [Budget] -> [History] -> [Int] hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) where @@ -116,22 +296,28 @@ hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) go (HistTransfer x) = Left x go (HistStatement x) = Right x -setDiff :: Eq a => [a] -> [a] -> ([a], [a]) --- setDiff = setDiff' (==) -setDiff as bs = (as \\ bs, bs \\ as) +setDiff2 :: Eq a => [a] -> [a] -> ([a], [a]) +setDiff2 = setDiffWith2 (==) --- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b]) --- setDiff' f = go [] --- where --- go inA [] bs = (inA, bs) --- go inA as [] = (as ++ inA, []) --- go inA (a:as) bs = case inB a bs of --- Just bs' -> go inA as bs' --- Nothing -> go (a:inA) as bs --- inB _ [] = Nothing --- inB a (b:bs) --- | f a b = Just bs --- | otherwise = inB a bs +-- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a]) +-- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs') + +-- setDiff as bs = (as \\ bs, bs \\ as) +setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b]) +setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs') + +setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b]) +setDiffWith f = go [] [] + where + go inA inBoth [] bs = (inA, inBoth, bs) + go inA inBoth as [] = (as ++ inA, inBoth, []) + go inA inBoth (a : as) bs = case inB a bs of + Just (b, bs') -> go inA ((a, b) : inBoth) as bs' + Nothing -> go (a : inA) inBoth as bs + inB _ [] = Nothing + inB a (b : bs) + | f a b = Just (b, bs) + | otherwise = inB a bs getDBHashes :: MonadSqlQuery m => m [Int] getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl @@ -148,42 +334,38 @@ getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int]) getConfigHashes bs hs = do let ch = hashConfig bs hs dh <- getDBHashes - return $ setDiff dh ch + return $ setDiff2 dh ch dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r] dumpTbl = selectE $ E.from E.table -deleteAccount :: MonadSqlQuery m => Entity AccountR -> m () -deleteAccount e = deleteE $ do - c <- E.from $ E.table @AccountR - E.where_ (c ^. AccountRId ==. E.val k) - where - k = entityKey e +-- deleteAccount :: MonadSqlQuery m => Entity AccountR -> m () +-- deleteAccount e = deleteE $ do +-- c <- E.from $ E.table @AccountR +-- E.where_ (c ^. AccountRId ==. E.val k) +-- where +-- k = entityKey e -deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m () -deleteCurrency e = deleteE $ do - c <- E.from $ E.table @CurrencyR - E.where_ (c ^. CurrencyRId ==. E.val k) - where - k = entityKey e +-- deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m () +-- deleteCurrency e = deleteE $ do +-- c <- E.from $ E.table @CurrencyR +-- E.where_ (c ^. CurrencyRId ==. E.val k) +-- where +-- k = entityKey e -deleteTag :: MonadSqlQuery m => Entity TagR -> m () -deleteTag e = deleteE $ do - c <- E.from $ E.table @TagR - E.where_ (c ^. TagRId ==. E.val k) - where - k = entityKey e +-- deleteTag :: MonadSqlQuery m => Entity TagR -> m () +-- deleteTag e = deleteE $ do +-- c <- E.from $ E.table @TagR +-- E.where_ (c ^. TagRId ==. E.val k) +-- where +-- k = entityKey e --- TODO slip-n-slide code... -insertFull - :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) - => Entity r - -> m () -insertFull (Entity k v) = insertKey k v - -currency2Record :: Currency -> Entity CurrencyR -currency2Record c@Currency {curSymbol, curFullname, curPrecision} = - Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) +-- -- TODO slip-n-slide code... +-- insertFull +-- :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) +-- => Entity r +-- -> m () +-- insertFull (Entity k v) = insertKey k v currencyMap :: [Entity CurrencyR] -> CurrencyMap currencyMap = @@ -198,40 +380,35 @@ currencyMap = toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b toKey = toSqlKey . fromIntegral . hash -tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR -tree2Entity t parents name des = - Entity (toSqlKey $ fromIntegral h) $ - AccountR name (toPath parents) des (accountSign t) +parentEntity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR +parentEntity t parents name des = + Entity (toSqlKey $ fromIntegral h) $ AccountR name p des (accountSign t) False where - p = AcntPath t (reverse (name : parents)) + p = AcntPath t (name : parents) h = hash p - toPath = T.intercalate "/" . (atName t :) . reverse -tree2Records - :: AcntType - -> AccountTree - -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntType))]) +tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR]) tree2Records t = go [] where go ps (Placeholder d n cs) = - let e = tree2Entity t (fmap snd ps) n d + let e = parentEntity t (fmap snd ps) n d k = entityKey e - (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs + (as, aps) = L.unzip $ fmap (go ((k, n) : ps)) cs a0 = acnt k n (fmap snd ps) d paths = expand k $ fmap fst ps - in (a0 : concat as, paths ++ concat aps, concat ms) + in (a0 : concat as, paths ++ concat aps) go ps (Account d n) = - let e = tree2Entity t (fmap snd ps) n d + let e = parentEntity t (fmap snd ps) n d k = entityKey e - in ( [acnt k n (fmap snd ps) d] - , expand k $ fmap fst ps - , [(AcntPath t $ reverse $ n : fmap snd ps, (k, t))] - ) - toPath = T.intercalate "/" . (atName t :) . reverse - acnt k n ps desc = Entity k $ AccountR n (toPath ps) desc sign - expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..] + in ([acnt k n (fmap snd ps) d], expand k $ fmap fst ps) + acnt k n ps desc = Entity k $ AccountR n (AcntPath t (n : ps)) desc sign True + expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..] sign = accountSign t +accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR +accountPathRecord p c d = + Entity (toKey (fromSqlKey p, fromSqlKey c)) $ AccountPathR p c d + paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)] paths2IDs = uncurry zip @@ -290,14 +467,18 @@ flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arE ++ ((AssetT,) <$> arAssets) ++ ((EquityT,) <$> arEquity) -indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap) -indexAcntRoot r = - ( concat ars - , concat aprs - , M.fromList $ paths2IDs $ concat ms - ) +makeAcntMap :: [Entity AccountR] -> AccountMap +makeAcntMap = + M.fromList + . paths2IDs + . fmap go + . filter (accountRLeaf . snd) + . fmap (\e -> (E.entityKey e, E.entityVal e)) where - (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r + go (k, v) = let p = accountRFullpath v in (p, (k, apType p)) + +indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR]) +indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot getDBState :: (MonadInsertError m, MonadSqlQuery m) @@ -310,7 +491,7 @@ getDBState c bs hs = do combineError bi si $ \b s -> ( DBState { kmCurrency = currencyMap cs - , kmAccount = am + , kmAccount = undefined , kmBudgetInterval = b , kmStatementInterval = s , kmTag = tagMap ts @@ -319,7 +500,7 @@ getDBState c bs hs = do , DBUpdates { duOldCommits = del , duNewTagIds = ts - , duNewAcntPaths = paths + , duNewAcntPaths = undefined , duNewAcntIds = acnts , duNewCurrencyIds = cs } @@ -327,7 +508,7 @@ getDBState c bs hs = do where bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c si = liftExcept $ resolveDaySpan $ statementInterval $ scope c - (acnts, paths, am) = indexAcntRoot $ accounts c + (acnts, _) = indexAcntRoot $ accounts c cs = currency2Record <$> currencies c ts = toRecord <$> tags c toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc @@ -336,35 +517,61 @@ getDBState c bs hs = do updateHashes :: (MonadSqlQuery m) => DBUpdates -> m () updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits -updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () -updateTags DBUpdates {duNewTagIds} = do - tags' <- selectE $ E.from $ E.table @TagR - let (toIns, toDel) = setDiff duNewTagIds tags' - mapM_ deleteTag toDel - mapM_ insertFull toIns +-- updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () +-- updateTags DBUpdates {duNewTagIds} = do +-- tags' <- selectE $ E.from $ E.table @TagR +-- let (toIns, toDel) = setDiff2 duNewTagIds tags' +-- mapM_ deleteTag toDel +-- mapM_ insertFull toIns -updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () -updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do - acnts' <- dumpTbl - let (toIns, toDel) = setDiff duNewAcntIds acnts' - deleteWhere ([] :: [Filter AccountPathR]) - mapM_ deleteAccount toDel - mapM_ insertFull toIns - mapM_ insert duNewAcntPaths +-- updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () +-- updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do +-- acnts' <- dumpTbl +-- let (toIns, toDel) = setDiff2 duNewAcntIds acnts' +-- deleteWhere ([] :: [Filter AccountPathR]) +-- mapM_ deleteAccount toDel +-- mapM_ insertFull toIns +-- mapM_ insert duNewAcntPaths -updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () -updateCurrencies DBUpdates {duNewCurrencyIds} = do - curs' <- selectE $ E.from $ E.table @CurrencyR - let (toIns, toDel) = setDiff duNewCurrencyIds curs' - mapM_ deleteCurrency toDel - mapM_ insertFull toIns +-- updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () +-- updateCurrencies DBUpdates {duNewCurrencyIds} = do +-- curs' <- selectE $ E.from $ E.table @CurrencyR +-- let (toIns, toDel) = setDiff2 duNewCurrencyIds curs' +-- mapM_ deleteCurrency toDel +-- mapM_ insertFull toIns -updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () -updateDBState u = do - updateHashes u - updateTags u - updateAccounts u - updateCurrencies u +updateCD + :: ( MonadSqlQuery m + , PersistRecordBackend a SqlBackend + , PersistRecordBackend b SqlBackend + ) + => CDOps (Entity a) (Key b) + -> 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 + mapM_ deleteKeyE dtTagRelations + +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) + +-- updateHashes u +-- updateTags u +-- updateAccounts u +-- updateCurrencies u deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) @@ -372,54 +579,95 @@ deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r] selectE q = unsafeLiftSql "esqueleto-select" (E.select q) -whenHash - :: (Hashable a, MonadFinance m, MonadSqlQuery m) - => ConfigType - -> a - -> b - -> (CommitRId -> m b) - -> m b -whenHash t o def f = do - let h = hash o - hs <- askDBState kmNewCommits - if h `elem` hs then f =<< insert (CommitR h t) else return def +deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m () +deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q) -whenHash0 - :: (Hashable a, MonadFinance m) - => ConfigType - -> a - -> b - -> (CommitR -> m b) - -> m b -whenHash0 t o def f = do - let h = hash o - hs <- askDBState kmNewCommits - if h `elem` hs then f (CommitR h t) else return def +insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m () +insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q) -eitherHash - :: (Hashable a, MonadFinance m) - => ConfigType - -> a - -> (CommitR -> m b) - -> (CommitR -> m c) - -> m (Either b c) -eitherHash t o f g = do - let h = hash o - let c = CommitR h t - hs <- askDBState kmNewCommits - if h `elem` hs then Right <$> g c else Left <$> f c +-- whenHash +-- :: (Hashable a, MonadFinance m, MonadSqlQuery m) +-- => ConfigType +-- -> a +-- -> b +-- -> (CommitRId -> m b) +-- -> m b +-- whenHash t o def f = do +-- let h = hash o +-- hs <- askDBState kmNewCommits +-- if h `elem` hs then f =<< insert (CommitR h t) else return def -whenHash_ - :: (Hashable a, MonadFinance m) - => ConfigType - -> a - -> m b - -> m (Maybe (CommitR, b)) -whenHash_ t o f = do - let h = hash o - let c = CommitR h t - hs <- askDBState kmNewCommits - if h `elem` hs then Just . (c,) <$> f else return Nothing +-- whenHash0 +-- :: (Hashable a, MonadFinance m) +-- => ConfigType +-- -> a +-- -> b +-- -> (CommitR -> m b) +-- -> m b +-- whenHash0 t o def f = do +-- let h = hash o +-- hs <- askDBState kmNewCommits +-- if h `elem` hs then f (CommitR h t) else return def + +-- eitherHash +-- :: (Hashable a, MonadFinance m) +-- => ConfigType +-- -> a +-- -> (CommitR -> m b) +-- -> (CommitR -> m c) +-- -> m (Either b c) +-- eitherHash t o f g = do +-- let h = hash o +-- let c = CommitR h t +-- hs <- askDBState kmNewCommits +-- if h `elem` hs then Right <$> g c else Left <$> f c + +-- whenHash_ +-- :: (Hashable a, MonadFinance m) +-- => ConfigType +-- -> a +-- -> m b +-- -> m (Maybe (CommitR, b)) +-- whenHash_ t o f = do +-- let h = hash o +-- let c = CommitR h t +-- hs <- askDBState kmNewCommits +-- if h `elem` hs then Just . (c,) <$> f else return Nothing + +readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([(Int, a)], [Int]) +readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do + rs <- selectE $ do + (commits :& _ :& entrysets :& entries :& tags) <- + E.from + $ E.table + `E.innerJoin` E.table + `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit) + `E.innerJoin` E.table + `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 :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry) + E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs) + return + ( commits ^. CommitRHash + , entrysets ^. EntrySetRCurrency + , entries ^. EntryRAccount + , tags ^. TagRelationRTag + ) + -- TODO there are faster ways to do this; may/may not matter + let cs = go ecCurrencies (\(i, c, _, _) -> (i, c)) rs + let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs + let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs + let valid = (cs `HS.intersection` as) `HS.intersection` ts + return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs + where + go existing f = + HS.fromList + . fmap (E.unValue . fst) + . L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd) + . groupKey id + . fmap f readUpdates :: (MonadInsertError m, MonadSqlQuery m) @@ -457,10 +705,12 @@ readUpdates hashes = do ) let (toUpdate, toRead) = L.partition (E.unValue . fst) xs toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate) - return (makeRE . snd <$> toRead, toUpdate') + let toRead' = fmap (makeRE . snd) toRead + return (toRead', toUpdate') where makeUES ((_, day, name, pri, (curID, prec)), es) = do let prec' = fromIntegral $ E.unValue prec + let cur = E.unValue curID let res = bimap NE.nonEmpty NE.nonEmpty $ NE.partition ((< 0) . entryRIndex . snd) $ @@ -477,7 +727,7 @@ readUpdates hashes = do Left $ UpdateEntrySet { utDate = E.unValue day - , utCurrency = E.unValue curID + , utCurrency = cur , utFrom0 = x , utTo0 = to0 , utFromRO = fromRO @@ -492,7 +742,7 @@ readUpdates hashes = do Right $ UpdateEntrySet { utDate = E.unValue day - , utCurrency = E.unValue curID + , utCurrency = cur , utFrom0 = x , utTo0 = to0 , utFromRO = fromRO @@ -504,7 +754,7 @@ readUpdates hashes = do , utPriority = E.unValue pri } _ -> throwError undefined - makeRE ((_, day, name, pri, (curID, prec)), entry) = + makeRE ((_, day, name, pri, (curID, prec)), entry) = do let e = entityVal entry in ReadEntry { reDate = E.unValue day diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 5cef870..7d54047 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -9,8 +9,8 @@ import Control.Monad.Except import Data.Csv import Data.Decimal import Data.Foldable +import Data.Hashable import GHC.Real -import Internal.Database import Internal.Types.Main import Internal.Utils import RIO hiding (to) @@ -39,10 +39,12 @@ splitHistory = partitionEithers . fmap go readHistTransfer :: (MonadInsertError m, MonadFinance m) => PairedTransfer - -> m (Either CommitR [Tx CommitR]) -readHistTransfer ht = eitherHash CTManual ht return $ \c -> do - bounds <- askDBState kmStatementInterval + -> m [Tx CommitR] +readHistTransfer ht = do + bounds <- askDBState csHistoryScope expandTransfer c historyName bounds ht + where + c = CommitR (hash ht) CTTransfer -------------------------------------------------------------------------------- -- Statements @@ -51,11 +53,13 @@ readHistStmt :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement - -> m (Either CommitR [Tx CommitR]) -readHistStmt root i = eitherHash CTImport i return $ \c -> do + -> m [Tx CommitR] +readHistStmt root i = do bs <- readImport root i - bounds <- askDBState kmStatementInterval + bounds <- askDBState csHistoryScope return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs + where + c = CommitR (hash i) CTTransfer -- TODO this probably won't scale well (pipes?) readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()] @@ -78,7 +82,7 @@ readImport_ -> m [TxRecord] readImport_ n delim tns p = do res <- tryIO $ BL.readFile p - bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res + bs <- fromEither $ first (InsertException . (: []) . InsertIOError . tshow) res case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of Left m -> throwIO $ InsertException [ParseError $ T.pack m] Right (_, v) -> return $ catMaybes $ V.toList v @@ -313,7 +317,7 @@ toTx } where curRes = do - m <- askDBState kmCurrency + m <- askDBState csCurrencyMap cur <- liftInner $ resolveCurrency m r tgCurrency let prec = cpPrec cur let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom @@ -327,7 +331,7 @@ resolveSubGetter -> TxSubGetter -> InsertExceptT m SecondayEntrySet resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do - m <- askDBState kmCurrency + m <- askDBState csCurrencyMap cur <- liftInner $ resolveCurrency m r tsgCurrency let prec = cpPrec cur let toRes = resolveHalfEntry resolveToValue prec r () tsgTo diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 1d4be04..9ece6d0 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -14,6 +14,7 @@ import RIO import qualified RIO.Text as T import RIO.Time +-- TODO use newtypes for all the different numbers so they don't get mixed up share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| @@ -21,20 +22,24 @@ CommitR sql=commits hash Int type ConfigType deriving Show Eq Ord +ConfigStateR sql=config_state + historyScopeHash Int + budgetScopeHash Int CurrencyR sql=currencies - symbol T.Text + symbol CurID fullname T.Text precision Int deriving Show Eq TagR sql=tags - symbol T.Text + symbol TagID fullname T.Text deriving Show Eq AccountR sql=accounts name T.Text - fullpath T.Text + fullpath AcntPath desc T.Text sign AcntSign + leaf Bool deriving Show Eq AccountPathR sql=account_paths parent AccountRId OnDeleteCascade @@ -70,7 +75,7 @@ TagRelationR sql=tag_relations deriving Show Eq |] -data ConfigType = CTBudget | CTManual | CTImport +data ConfigType = CTBudget | CTTransfer | CTHistory deriving (Eq, Show, Read, Enum, Ord) instance PersistFieldSql ConfigType where @@ -97,3 +102,38 @@ instance PersistField AcntSign where fromPersistValue (PersistInt64 (-1)) = Right Credit fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v fromPersistValue _ = Left "not an Int64" + +data AcntType + = AssetT + | EquityT + | ExpenseT + | IncomeT + | LiabilityT + deriving (Show, Eq, Ord, Hashable, Generic, Read) + +atName :: AcntType -> T.Text +atName AssetT = "asset" +atName EquityT = "equity" +atName ExpenseT = "expense" +atName IncomeT = "income" +atName LiabilityT = "liability" + +data AcntPath = AcntPath + { apType :: !AcntType + , apChildren :: ![T.Text] + } + deriving (Eq, Ord, Show, Hashable, Generic, Read) + +instance PersistFieldSql AcntPath where + sqlType _ = SqlString + +instance PersistField AcntPath where + toPersistValue (AcntPath t cs) = + PersistText $ T.intercalate "/" $ (atName t :) $ reverse cs + + fromPersistValue (PersistText v) = case T.split (== '/') v of + [] -> Left "path is empty" + (x : xs) -> case readMaybe $ T.unpack x of + Just t -> Right $ AcntPath t $ reverse xs + _ -> Left "could not get account type" + fromPersistValue _ = Left "not a string" diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index 5cb6af0..a4b6ba4 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -371,7 +371,7 @@ data AccountRoot_ a = AccountRoot_ , arIncome :: ![a] , arLiabilities :: ![a] } - deriving (Generic) + deriving (Generic, Hashable) type AccountRootF = AccountRoot_ (Fix AccountTreeF) diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 2e36bc2..5d96fb7 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE UndecidableInstances #-} @@ -17,7 +16,6 @@ import Database.Persist.Sql hiding (Desc, In, Statement) import Dhall hiding (embed, maybe) import Internal.Types.Database import Internal.Types.Dhall -import Language.Haskell.TH.Syntax (Lift) import RIO import qualified RIO.Map as M import qualified RIO.NonEmpty as NE @@ -35,6 +33,36 @@ data ConfigHashes = ConfigHashes , chImport :: ![Int] } +data DeleteTxs = DeleteTxs + { dtTxs :: ![TransactionRId] + , dtEntrySets :: ![EntrySetRId] + , dtEntries :: ![EntryRId] + , dtTagRelations :: ![TagRelationRId] + } + +type CDOps c d = CRUDOps [c] () () [d] + +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 :: !DaySpan + , csHistoryScope :: !DaySpan + } + +data ExistingConfig = ExistingConfig + { ecAccounts :: !(HashSet Int) + , ecTags :: !(HashSet Int) + , ecCurrencies :: !(HashSet Int) + } + type AccountMap = M.Map AcntID (AccountRId, AcntType) data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision} @@ -44,6 +72,23 @@ type CurrencyMap = M.Map CurID CurrencyPrec type TagMap = M.Map TagID TagRId +data CRUDOps c r u d = CRUDOps + { coCreate :: !c + , coRead :: !r + , coUpdate :: !u + , coDelete :: !d + } + +data DBState_ = DBState_ + { dbsCurrencyMap :: !CurrencyMap + , dbsAccountMap :: !AccountMap + , dbsTagMap :: !TagMap + , dbsBudgetInterval :: !DaySpan + , dbsHistoryInterval :: !DaySpan + , dbsNewCommits :: ![Int] + } + deriving (Show) + data DBState = DBState { kmCurrency :: !CurrencyMap , kmAccount :: !AccountMap @@ -63,8 +108,6 @@ data DBUpdates = DBUpdates } deriving (Show) -type CurrencyM = Reader CurrencyMap - data DBDeferred = DBEntryLinked Natural Double | DBEntryBalance Decimal @@ -138,35 +181,14 @@ data EntryBin type TreeR = Tree ([T.Text], AccountRId) -type MonadFinance = MonadReader DBState +type MonadFinance = MonadReader ConfigState -askDBState :: MonadFinance m => (DBState -> a) -> m a +askDBState :: MonadFinance m => (ConfigState -> a) -> m a askDBState = asks ------------------------------------------------------------------------------- -- misc -data AcntType - = AssetT - | EquityT - | ExpenseT - | IncomeT - | LiabilityT - deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) - -atName :: AcntType -> T.Text -atName AssetT = "asset" -atName EquityT = "equity" -atName ExpenseT = "expense" -atName IncomeT = "income" -atName LiabilityT = "liability" - -data AcntPath = AcntPath - { apType :: !AcntType - , apChildren :: ![T.Text] - } - deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) - data TxRecord = TxRecord { trDate :: !Day , trAmount :: !Decimal @@ -178,19 +200,8 @@ data TxRecord = TxRecord type DaySpan = (Day, Natural) -data Keyed a = Keyed - { kKey :: !Int64 - , kVal :: !a - } - deriving (Eq, Show, Functor) - data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) --- TODO debit should be negative -sign2Int :: AcntSign -> Int -sign2Int Debit = 1 -sign2Int Credit = 1 - accountSign :: AcntType -> AcntSign accountSign AssetT = Debit accountSign ExpenseT = Debit diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index e5758be..c68490f 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -152,7 +152,7 @@ askDays -> Maybe Interval -> m [Day] askDays dp i = do - globalSpan <- askDBState kmBudgetInterval + globalSpan <- askDBState csBudgetScope case i of Just i' -> do localSpan <- liftExcept $ resolveDaySpan i' @@ -419,14 +419,6 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] txt = T.pack . show pad i c z = T.append (T.replicate (i - T.length z) c) z --- roundPrecision :: Natural -> Double -> Rational --- roundPrecision n = (% p) . round . (* fromIntegral p) . toRational --- where --- p = 10 ^ n - --- roundPrecisionCur :: CurrencyPrec -> Double -> Rational --- roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n - acntPath2Text :: AcntPath -> T.Text acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) @@ -638,7 +630,7 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType) -lookupAccount = lookupFinance AcntField kmAccount +lookupAccount = lookupFinance AcntField csAccountMap lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId lookupAccountKey = fmap fst . lookupAccount @@ -647,7 +639,7 @@ lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntTyp lookupAccountType = fmap snd . lookupAccount lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec -lookupCurrency = lookupFinance CurField kmCurrency +lookupCurrency = lookupFinance CurField csCurrencyMap lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId lookupCurrencyKey = fmap cpID . lookupCurrency @@ -656,12 +648,12 @@ lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precis lookupCurrencyPrec = fmap cpPrec . lookupCurrency lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId -lookupTag = lookupFinance TagField kmTag +lookupTag = lookupFinance TagField csTagMap lookupFinance :: (MonadInsertError m, MonadFinance m) => EntryIDType - -> (DBState -> M.Map T.Text a) + -> (ConfigState -> M.Map T.Text a) -> T.Text -> m a lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f @@ -865,7 +857,7 @@ balancePrimaryEntrySet combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $ \(f0', fs') (t0', ts') -> do let balFrom = fmap liftInnerS . balanceDeferred - fs'' <- doEntries balFrom bc esTotalValue f0' fs' + fs'' <- balanceTotalEntrySet balFrom bc esTotalValue f0' fs' balanceFinal bc (-esTotalValue) fs'' t0' ts' balanceSecondaryEntrySet @@ -904,7 +896,7 @@ balanceFinal balanceFinal k@(curID, _) tot fs t0 ts = do let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs let balTo = balanceLinked fv - ts' <- doEntries balTo k tot t0 ts + ts' <- balanceTotalEntrySet balTo k tot t0 ts return $ InsertEntrySet { iesCurrency = curID @@ -912,7 +904,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do , iesToEntries = ts' } -doEntries +balanceTotalEntrySet :: (MonadInsertError m) => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred)) -> BCKey @@ -920,7 +912,7 @@ doEntries -> Entry AccountRId () TagRId -> [Entry AccountRId v TagRId] -> StateT EntryBals m (NonEmpty InsertEntry) -doEntries f k tot e@Entry {eAcnt = acntID} es = do +balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do es' <- mapErrors (balanceEntry f k) es let e0val = tot - entrySum es' -- TODO not dry