WIP use more robust update strategy

This commit is contained in:
Nathan Dwarshuis 2023-07-13 23:31:27 -04:00
parent c8f7689c7a
commit 4c46f035f5
8 changed files with 557 additions and 274 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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