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