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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
app/Main.hs
View File

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

2
lib/Internal/Budget.hs
View File

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

134
lib/Internal/Database.hs
View File

@ -22,7 +22,7 @@ import Control.Monad.Except
import Control.Monad.Logger import Control.Monad.Logger
import Data.Decimal import Data.Decimal
import Data.Hashable import Data.Hashable
import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.)) import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
import qualified Database.Esqueleto.Experimental as E 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
@ -42,11 +42,10 @@ 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 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.Set as S
import qualified RIO.Text as T import qualified RIO.Text as T
runDB runDB
@ -126,30 +125,30 @@ readConfigState
-> [History] -> [History]
-> m ConfigState -> m ConfigState
readConfigState c bs hs = do readConfigState c bs hs = do
curAcnts <- readCurrentIds AccountRId (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
curTags <- readCurrentIds TagRId (pathsIns, _, pathsDel) <- diff newPaths
curCurs <- readCurrentIds CurrencyRId (curs2Ins, cursRem, curs2Del) <- diff newCurs
curPaths <- readCurrentIds AccountPathRId (tags2Ins, tagsRem, tags2Del) <- diff newTags
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 amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem) let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem) 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 = let existing =
ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap) ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
(bChanged, hChanged) <- readScopeChanged $ scope c -- 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 bgt <- makeTxCRUD existing bs curBgts bChanged
hTrans <- makeTxCRUD existing ts curHistTrs hChanged hTrans <- makeTxCRUD existing ts curHistTrs hChanged
hStmt <- makeTxCRUD existing ss curHistSts hChanged hStmt <- makeTxCRUD existing ss curHistSts hChanged
let bsRes = resolveScope budgetInterval return $
let hsRes = resolveScope statementInterval
combineError bsRes hsRes $ \b h ->
ConfigState ConfigState
{ csCurrencies = CRUDOps curs2Ins () () curs2Del { csCurrencies = CRUDOps curs2Ins () () curs2Del
, csTags = CRUDOps tags2Ins () () tags2Del , csTags = CRUDOps tags2Ins () () tags2Del
@ -161,32 +160,31 @@ readConfigState c bs hs = do
, csAccountMap = amap , csAccountMap = amap
, csCurrencyMap = cmap , csCurrencyMap = cmap
, csTagMap = tmap , csTagMap = tmap
, csBudgetScope = b , csBudgetScope = bscope
, csHistoryScope = h , csHistoryScope = hscope
} }
where where
(ts, ss) = splitHistory hs (ts, ss) = splitHistory hs
diff :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a]) diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
diff = setDiffWith (\a b -> E.entityKey a == b)
(newAcnts, newPaths) = indexAcntRoot $ accounts c (newAcnts, newPaths) = indexAcntRoot $ accounts c
newTags = tag2Record <$> tags c newTags = tag2Record <$> tags c
newCurs = currency2Record <$> currencies c newCurs = currency2Record <$> currencies c
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
readScopeChanged :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool) readScopeChanged
readScopeChanged s = do :: (MonadInsertError m, MonadSqlQuery m)
=> Bool
-> BudgetSpan
-> HistorySpan
-> m (Bool, Bool)
readScopeChanged dbempty bscope hscope = do
rs <- dumpTbl rs <- dumpTbl
case rs of case rs of
[] -> return (True, True) [] -> if dbempty then return (True, True) else throwError undefined
[r] -> do [r] -> do
let (ConfigStateR hsh bsh) = E.entityVal r let (ConfigStateR h b) = E.entityVal r
return return (bscope /= b, hscope /= h)
( hashScope budgetInterval == bsh
, hashScope statementInterval == hsh
)
_ -> throwError undefined _ -> throwError undefined
where
hashScope f = hash $ f s
makeTxCRUD makeTxCRUD
:: (MonadInsertError m, MonadSqlQuery m, Hashable a) :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
@ -202,13 +200,13 @@ makeTxCRUD
DeleteTxs DeleteTxs
) )
makeTxCRUD existing newThings curThings scopeChanged = do 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 -- 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 -- won't exist on the next update. Those with invalid IDs will be set aside
-- to delete and reinsert (which may also fail) later -- to delete and reinsert (which may also fail) later
(toInsRetry, noRetry) <- readInvalidIds existing overlap (noRetry, toInsRetry) <- readInvalidIds existing overlap
let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry) let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
let toInsAll = (snd <$> toInsRetry) ++ toIns
-- If we are inserting or deleting something or the scope changed, pull out -- 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 -- 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 -- stuff (this is necessary because a given transaction may depend on the
@ -218,8 +216,6 @@ makeTxCRUD existing newThings curThings scopeChanged = do
_ -> readUpdates noRetry _ -> readUpdates noRetry
toDelAll <- readTxIds toDelAllHashes toDelAll <- readTxIds toDelAllHashes
return $ CRUDOps toInsAll toRead toUpdate toDelAll return $ CRUDOps toInsAll toRead toUpdate toDelAll
where
go a b = hash b == a
readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
readTxIds cs = do readTxIds cs = do
@ -270,10 +266,10 @@ currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname, curPrecision} = currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a] readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
rs <- E.from E.table rs <- E.from E.table
return (rs ^. f) return (rs ^. E.persistIdField)
readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int]) readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
readCurrentCommits = do readCurrentCommits = do
@ -286,8 +282,8 @@ readCurrentCommits = do
let y = E.unValue x let y = E.unValue x
in case E.unValue t of in case E.unValue t of
CTBudget -> (y : bs, ts, hs) CTBudget -> (y : bs, ts, hs)
CTTransfer -> (bs, y : ts, hs) CTHistoryTransfer -> (bs, y : ts, hs)
CTHistory -> (bs, ts, y : hs) CTHistoryStatement -> (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)
@ -311,13 +307,16 @@ setDiffWith f = go [] []
where where
go inA inBoth [] bs = (inA, inBoth, bs) go inA inBoth [] bs = (inA, inBoth, bs)
go inA inBoth as [] = (as ++ inA, inBoth, []) go inA inBoth as [] = (as ++ inA, inBoth, [])
go inA inBoth (a : as) bs = case inB a bs of go inA inBoth (a : as) bs =
Just (b, bs') -> go inA ((a, b) : inBoth) as bs' let (res, bs') = findDelete (f a) bs
in case res of
Nothing -> go (a : inA) inBoth as bs Nothing -> go (a : inA) inBoth as bs
inB _ [] = Nothing Just b -> go inA ((a, b) : inBoth) as bs'
inB a (b : bs)
| f a b = Just (b, bs) findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
| otherwise = inB a bs findDelete f xs = case break f xs of
(ys, []) -> (Nothing, ys)
(ys, z : zs) -> (Just z, ys ++ zs)
-- getDBHashes :: MonadSqlQuery m => m [Int] -- getDBHashes :: MonadSqlQuery m => m [Int]
-- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl -- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
@ -594,23 +593,24 @@ updateDBState = do
deleteTxs =<< asks (coDelete . csBudgets) deleteTxs =<< asks (coDelete . csBudgets)
deleteTxs =<< asks (coDelete . csHistTrans) deleteTxs =<< asks (coDelete . csHistTrans)
deleteTxs =<< asks (coDelete . csHistStmts) deleteTxs =<< asks (coDelete . csHistStmts)
b <- asks csBudgetScope
-- updateHashes u h <- asks csHistoryScope
-- updateTags u repsertE (E.toSqlKey 1) $ ConfigStateR h b
-- 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)
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 :: (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)
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m () 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 :: (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 -- whenHash
-- :: (Hashable a, MonadFinance m, MonadSqlQuery m) -- :: (Hashable a, MonadFinance m, MonadSqlQuery m)
@ -661,7 +661,7 @@ insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
-- hs <- askDBState kmNewCommits -- hs <- askDBState kmNewCommits
-- if h `elem` hs then Just . (c,) <$> f else return Nothing -- 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 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
rs <- selectE $ do rs <- selectE $ do
(commits :& _ :& entrysets :& entries :& tags) <- (commits :& _ :& entrysets :& entries :& tags) <-
@ -673,28 +673,28 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction) `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
`E.innerJoin` E.table `E.innerJoin` E.table
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset) `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
`E.innerJoin` E.table `E.leftJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry) `E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs) E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
return return
( commits ^. CommitRHash ( commits ^. CommitRHash
, entrysets ^. EntrySetRCurrency , entrysets ^. EntrySetRCurrency
, entries ^. EntryRAccount , entries ^. EntryRAccount
, tags ^. TagRelationRTag , tags ?. TagRelationRTag
) )
-- TODO there are faster ways to do this; may/may not matter -- TODO there are faster ways to do this; may/may not matter
let cs = go ecCurrencies (\(i, c, _, _) -> (i, c)) rs let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
let valid = (cs `HS.intersection` as) `HS.intersection` ts let valid = (cs `S.intersection` as) `S.intersection` ts
return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
return (a0, [])
where where
go existing f = go existing =
HS.fromList S.fromList
. fmap (E.unValue . fst) . 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 . groupKey id
. fmap f
readUpdates readUpdates
:: (MonadInsertError m, MonadSqlQuery m) :: (MonadInsertError m, MonadSqlQuery m)

8
lib/Internal/History.hs
View File

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

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

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

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

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

2
lib/Internal/Utils.hs
View File

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