FIX update bugs

This commit is contained in:
Nathan Dwarshuis 2023-07-15 23:25:28 -04:00
parent 223be34145
commit 8901fd6a64
7 changed files with 144 additions and 120 deletions

View File

@ -8,6 +8,7 @@ import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Bitraversable
-- import Data.Hashable
import qualified Data.Text.IO as TI
import qualified Database.Esqueleto.Experimental as E
import Database.Persist.Monad
@ -20,7 +21,7 @@ import Internal.Utils
import Options.Applicative
import RIO
import RIO.FilePath
import qualified RIO.Map as M
-- import qualified RIO.Map as M
import qualified RIO.Text as T
main :: IO ()
@ -233,7 +234,7 @@ runSync threads c bs hs = do
-- TODO for some mysterious reason using multithreading just for this
-- little bit slows the program down by several seconds
-- lift $ setNumCapabilities threads
(liftIO . print) =<< askDBState (M.keys . csAccountMap)
-- (liftIO . print) =<< askDBState (M.keys . csAccountMap)
-- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
(CRUDOps hSs _ _ _) <- askDBState csHistStmts
hSs' <- mapErrorsIO (readHistStmt root) hSs
@ -247,12 +248,19 @@ runSync threads c bs hs = do
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
-- lift $ print $ length $ lefts bTs
return $ concat $ hSs' ++ hTs' ++ bTs'
-- print $ length $ kmNewCommits state
-- print $ length $ duOldCommits updates
-- print $ length $ duNewTagIds updates
-- print $ length $ duNewAcntPaths updates
-- print $ length $ duNewAcntIds updates
-- print $ length $ duNewCurrencyIds updates
print $ length $ coCreate $ csBudgets state
print $ length $ coCreate $ csHistTrans state
print $ length $ coCreate $ csHistStmts state
print $ length $ coUpdate $ csBudgets state
print $ length $ coUpdate $ csHistTrans state
print $ length $ coUpdate $ csHistStmts state
print $ length $ coRead $ csBudgets state
print $ length $ coRead $ csHistTrans state
print $ length $ coRead $ csHistStmts state
print $ coDelete $ csBudgets state
print $ coDelete $ csHistTrans state
print $ coDelete $ csHistStmts state
-- print $ fmap hash $ coCreate $ csHistStmts state
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do

View File

@ -49,7 +49,7 @@ readBudget
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
getSpan = do
globalSpan <- askDBState csBudgetScope
globalSpan <- askDBState (unBSpan . csBudgetScope)
case bgtInterval of
Nothing -> return $ Just globalSpan
Just bi -> do

View File

@ -22,7 +22,7 @@ import Control.Monad.Except
import Control.Monad.Logger
import Data.Decimal
import Data.Hashable
import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.))
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Internal.Internal (SqlSelect)
import Database.Persist.Monad
@ -42,11 +42,10 @@ import GHC.Err
import Internal.Types.Main
import Internal.Utils
import RIO hiding (LogFunc, isNothing, on, (^.))
import qualified RIO.HashSet as HS
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
-- import qualified RIO.Set as S
import qualified RIO.Set as S
import qualified RIO.Text as T
runDB
@ -126,67 +125,66 @@ readConfigState
-> [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
(acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
(pathsIns, _, pathsDel) <- diff newPaths
(curs2Ins, cursRem, curs2Del) <- diff newCurs
(tags2Ins, tagsRem, tags2Del) <- diff newTags
let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
let fromMap f = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems
let fromMap f = S.fromList . fmap f . M.elems
let existing =
ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
(bChanged, hChanged) <- readScopeChanged $ scope c
bgt <- makeTxCRUD existing bs curBgts bChanged
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
hStmt <- makeTxCRUD existing ss curHistSts hChanged
-- TODO refine this test to include the whole db (with data already mixed
-- in this algorithm)
let bsRes = BudgetSpan <$> resolveScope budgetInterval
let hsRes = HistorySpan <$> resolveScope statementInterval
combineErrorM bsRes hsRes $ \bscope hscope -> do
let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
bgt <- makeTxCRUD existing bs curBgts bChanged
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
hStmt <- makeTxCRUD existing ss curHistSts hChanged
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
}
return $
ConfigState
{ csCurrencies = CRUDOps curs2Ins () () curs2Del
, csTags = CRUDOps tags2Ins () () tags2Del
, csAccounts = CRUDOps acnts2Ins () () acnts2Del
, csPaths = CRUDOps pathsIns () () pathsDel
, csBudgets = bgt
, csHistTrans = hTrans
, csHistStmts = hStmt
, csAccountMap = amap
, csCurrencyMap = cmap
, csTagMap = tmap
, csBudgetScope = bscope
, csHistoryScope = hscope
}
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)
diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
(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
readScopeChanged
:: (MonadInsertError m, MonadSqlQuery m)
=> Bool
-> BudgetSpan
-> HistorySpan
-> m (Bool, Bool)
readScopeChanged dbempty bscope hscope = do
rs <- dumpTbl
case rs of
[] -> return (True, True)
[] -> if dbempty then return (True, True) else throwError undefined
[r] -> do
let (ConfigStateR hsh bsh) = E.entityVal r
return
( hashScope budgetInterval == bsh
, hashScope statementInterval == hsh
)
let (ConfigStateR h b) = E.entityVal r
return (bscope /= b, hscope /= h)
_ -> throwError undefined
where
hashScope f = hash $ f s
makeTxCRUD
:: (MonadInsertError m, MonadSqlQuery m, Hashable a)
@ -202,13 +200,13 @@ makeTxCRUD
DeleteTxs
)
makeTxCRUD existing newThings curThings scopeChanged = do
let (toDelHashes, overlap, toIns) = setDiffWith go curThings newThings
let (toDelHashes, overlap, toIns) =
setDiffWith (\a b -> hash b == a) curThings newThings
-- Check the overlap for rows with accounts/tags/currencies that
-- won't exist on the next update. Those with invalid IDs will be set aside
-- to delete and reinsert (which may also fail) later
(toInsRetry, noRetry) <- readInvalidIds existing overlap
let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry)
let toInsAll = (snd <$> toInsRetry) ++ toIns
(noRetry, toInsRetry) <- readInvalidIds existing overlap
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
-- If we are inserting or deleting something or the scope changed, pull out
-- the remainder of the entries to update/read as we are (re)inserting other
-- stuff (this is necessary because a given transaction may depend on the
@ -218,8 +216,6 @@ makeTxCRUD existing newThings curThings scopeChanged = do
_ -> 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
@ -270,10 +266,10 @@ 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
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
rs <- E.from E.table
return (rs ^. f)
return (rs ^. E.persistIdField)
readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
readCurrentCommits = do
@ -286,8 +282,8 @@ readCurrentCommits = do
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)
CTHistoryTransfer -> (bs, y : ts, hs)
CTHistoryStatement -> (bs, ts, y : hs)
-- hashConfig :: [Budget] -> [History] -> [Int]
-- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
@ -311,13 +307,16 @@ setDiffWith f = go [] []
where
go inA inBoth [] bs = (inA, inBoth, bs)
go inA inBoth as [] = (as ++ inA, inBoth, [])
go inA inBoth (a : as) bs = case inB a bs of
Just (b, bs') -> go inA ((a, b) : inBoth) as bs'
Nothing -> go (a : inA) inBoth as bs
inB _ [] = Nothing
inB a (b : bs)
| f a b = Just (b, bs)
| otherwise = inB a bs
go inA inBoth (a : as) bs =
let (res, bs') = findDelete (f a) bs
in case res of
Nothing -> go (a : inA) inBoth as bs
Just b -> go inA ((a, b) : inBoth) as bs'
findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
findDelete f xs = case break f xs of
(ys, []) -> (Nothing, ys)
(ys, z : zs) -> (Just z, ys ++ zs)
-- getDBHashes :: MonadSqlQuery m => m [Int]
-- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
@ -594,23 +593,24 @@ updateDBState = do
deleteTxs =<< asks (coDelete . csBudgets)
deleteTxs =<< asks (coDelete . csHistTrans)
deleteTxs =<< asks (coDelete . csHistStmts)
-- updateHashes u
-- updateTags u
-- updateAccounts u
-- updateCurrencies u
b <- asks csBudgetScope
h <- asks csHistoryScope
repsertE (E.toSqlKey 1) $ ConfigStateR h b
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q)
deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
-- whenHash
-- :: (Hashable a, MonadFinance m, MonadSqlQuery m)
@ -661,7 +661,7 @@ insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
-- 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 :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
rs <- selectE $ do
(commits :& _ :& entrysets :& entries :& tags) <-
@ -673,28 +673,28 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
`E.innerJoin` E.table
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
`E.innerJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry)
`E.leftJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
return
( commits ^. CommitRHash
, entrysets ^. EntrySetRCurrency
, entries ^. EntryRAccount
, tags ^. TagRelationRTag
, 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
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
let valid = (cs `S.intersection` as) `S.intersection` ts
let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
return (a0, [])
where
go existing f =
HS.fromList
go existing =
S.fromList
. fmap (E.unValue . fst)
. L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd)
. L.filter (all (`S.member` existing) . snd)
. groupKey id
. fmap f
readUpdates
:: (MonadInsertError m, MonadSqlQuery m)

View File

@ -41,10 +41,10 @@ readHistTransfer
=> PairedTransfer
-> m [Tx CommitR]
readHistTransfer ht = do
bounds <- askDBState csHistoryScope
bounds <- askDBState (unHSpan . csHistoryScope)
expandTransfer c historyName bounds ht
where
c = CommitR (hash ht) CTTransfer
c = CommitR (hash ht) CTHistoryTransfer
--------------------------------------------------------------------------------
-- Statements
@ -56,10 +56,10 @@ readHistStmt
-> m [Tx CommitR]
readHistStmt root i = do
bs <- readImport root i
bounds <- askDBState csHistoryScope
bounds <- askDBState (unHSpan . csHistoryScope)
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
where
c = CommitR (hash i) CTTransfer
c = CommitR (hash i) CTHistoryStatement
-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]

View File

@ -22,47 +22,54 @@ share
CommitR sql=commits
hash Int
type ConfigType
UniqueCommitHash hash
deriving Show Eq Ord
ConfigStateR sql=config_state
historyScopeHash Int
budgetScopeHash Int
historySpan HistorySpan
budgetSpan BudgetSpan
deriving Show
CurrencyR sql=currencies
symbol CurID
fullname T.Text
precision Int
deriving Show Eq
UniqueCurrencySymbol symbol
UniqueCurrencyFullname fullname
deriving Show Eq Ord
TagR sql=tags
symbol TagID
fullname T.Text
deriving Show Eq
UniqueTagSymbol symbol
UniqueTagFullname fullname
deriving Show Eq Ord
AccountR sql=accounts
name T.Text
fullpath AcntPath
desc T.Text
sign AcntSign
leaf Bool
deriving Show Eq
UniqueAccountFullpath fullpath
deriving Show Eq Ord
AccountPathR sql=account_paths
parent AccountRId OnDeleteCascade
child AccountRId OnDeleteCascade
parent AccountRId
child AccountRId
depth Int
deriving Show Eq
deriving Show Eq Ord
TransactionR sql=transactions
commit CommitRId OnDeleteCascade
commit CommitRId
date Day
description T.Text
budgetName T.Text
priority Int
deriving Show Eq
EntrySetR sql=entry_sets
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
transaction TransactionRId
currency CurrencyRId
index Int
rebalance Bool
deriving Show Eq
EntryR sql=entries
entryset EntrySetRId OnDeleteCascade
account AccountRId OnDeleteCascade
entryset EntrySetRId
account AccountRId
memo T.Text
value Rational
index Int
@ -71,12 +78,20 @@ EntryR sql=entries
cachedLink (Maybe Int)
deriving Show Eq
TagRelationR sql=tag_relations
entry EntryRId OnDeleteCascade
tag TagRId OnDeleteCascade
entry EntryRId
tag TagRId
deriving Show Eq
|]
data ConfigType = CTBudget | CTTransfer | CTHistory
type DaySpan = (Day, Int)
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
deriving (Eq, Show, Read, Enum, Ord)
instance PersistFieldSql ConfigType where

View File

@ -39,6 +39,7 @@ data DeleteTxs = DeleteTxs
, dtEntries :: ![EntryRId]
, dtTagRelations :: ![TagRelationRId]
}
deriving (Show)
type CDOps c d = CRUDOps [c] () () [d]
@ -53,14 +54,15 @@ data ConfigState = ConfigState
, csAccountMap :: !AccountMap
, csCurrencyMap :: !CurrencyMap
, csTagMap :: !TagMap
, csBudgetScope :: !DaySpan
, csHistoryScope :: !DaySpan
, csBudgetScope :: !BudgetSpan
, csHistoryScope :: !HistorySpan
}
deriving (Show)
data ExistingConfig = ExistingConfig
{ ecAccounts :: !(HashSet Int)
, ecTags :: !(HashSet Int)
, ecCurrencies :: !(HashSet Int)
{ ecAccounts :: !(Set AccountRId)
, ecTags :: !(Set TagRId)
, ecCurrencies :: !(Set CurrencyRId)
}
type AccountMap = M.Map AcntID (AccountRId, AcntType)
@ -78,6 +80,7 @@ data CRUDOps c r u d = CRUDOps
, coUpdate :: !u
, coDelete :: !d
}
deriving (Show)
data DBState_ = DBState_
{ dbsCurrencyMap :: !CurrencyMap
@ -198,8 +201,6 @@ data TxRecord = TxRecord
}
deriving (Show, Eq, Ord)
type DaySpan = (Day, Natural)
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
accountSign :: AcntType -> AcntSign

View File

@ -151,7 +151,7 @@ askDays
-> Maybe Interval
-> m [Day]
askDays dp i = do
globalSpan <- askDBState csBudgetScope
globalSpan <- askDBState (unBSpan . csBudgetScope)
case i of
Just i' -> do
localSpan <- liftExcept $ resolveDaySpan i'