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