ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

FIX history updates

This commit is contained in:
Nathan Dwarshuis 2023-07-20 00:25:33 -04:00
parent e6f97651e5
commit bd94afd30f
7 changed files with 380 additions and 254 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
app/Main.hs
View File

@ -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

25
lib/Internal/Budget.hs
View File

@ -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

397
lib/Internal/Database.hs
View File

@ -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
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope let dbempty = null curAcnts && null curCurs && null curTags
bgt <- makeTxCRUD existing bs curBgts bChanged let meta =
hTrans <- makeTxCRUD existing ts curHistTrs hChanged MetaCRUD
hStmt <- makeTxCRUD existing ss curHistSts hChanged { mcCurrencies = makeCD newCurs curCurs
, mcTags = makeCD newTags curTags
return $ , mcAccounts = makeCD newAcnts curAcnts
ConfigState , mcPaths = makeCD newPaths curPaths
{ csCurrencies = CRUDOps curs2Ins () () curs2Del , mcBudgetScope = bscope
, csTags = CRUDOps tags2Ins () () tags2Del , mcHistoryScope = hscope
, csAccounts = CRUDOps acnts2Ins () () acnts2Del
, csPaths = CRUDOps pathsIns () () pathsDel
, csBudgets = bgt
, csHistTrans = hTrans
, csHistStmts = hStmt
, csAccountMap = amap
, csCurrencyMap = cmap
, csTagMap = tmap
, csBudgetScope = bscope
, csHistoryScope = hscope
} }
let txS =
TxState
{ tsAccountMap = amap
, tsCurrencyMap = cmap
, tsTagMap = tmap
, tsBudgetScope = bscope
, tsHistoryScope = hscope
}
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
budgets <- makeBudgetCRUD existing bs curBgts bChanged
history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged
return (meta, txS, budgets, history)
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 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 name ck) ts
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () insertHistory
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority => 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 historyName ck) ts
deleteTxs ds
-- 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) 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"

43
lib/Internal/History.hs
View File

@ -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"

2
lib/Internal/Types/Database.hs
View File

@ -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

63
lib/Internal/Types/Main.hs
View File

@ -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)

58
lib/Internal/Utils.hs
View File

@ -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
} }