WIP use more robust update strategy
This commit is contained in:
parent
c8f7689c7a
commit
4c46f035f5
35
app/Main.hs
35
app/Main.hs
|
|
@ -9,6 +9,7 @@ import Control.Monad.Logger
|
|||
import Control.Monad.Reader
|
||||
import Data.Bitraversable
|
||||
import qualified Data.Text.IO as TI
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Persist.Monad
|
||||
import qualified Dhall hiding (double, record)
|
||||
import Internal.Budget
|
||||
|
|
@ -194,14 +195,13 @@ runDumpAccountKeys c = do
|
|||
ar <- accounts <$> readConfig c
|
||||
let ks =
|
||||
paths2IDs $
|
||||
fmap (double . fst) $
|
||||
concatMap (t3 . uncurry tree2Records) $
|
||||
flattenAcntRoot ar
|
||||
fmap (double . accountRFullpath . E.entityVal) $
|
||||
fst $
|
||||
indexAcntRoot ar
|
||||
mapM_ (uncurry printPair) ks
|
||||
where
|
||||
printPair i p = do
|
||||
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
|
||||
t3 (_, _, x) = x
|
||||
double x = (x, x)
|
||||
|
||||
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
||||
|
|
@ -221,27 +221,29 @@ runSync threads c bs hs = do
|
|||
-- _ <- askLoggerIO
|
||||
|
||||
-- Get the current DB state.
|
||||
(state, updates) <- runSqlQueryT pool $ do
|
||||
state <- runSqlQueryT pool $ do
|
||||
runMigration migrateAll
|
||||
liftIOExceptT $ getDBState config bs' hs'
|
||||
liftIOExceptT $ readConfigState config bs' hs'
|
||||
|
||||
-- Read raw transactions according to state. If a transaction is already in
|
||||
-- the database, don't read it but record the commit so we can update it.
|
||||
(rus, is) <-
|
||||
toIns <-
|
||||
flip runReaderT state $ do
|
||||
let (hTs, hSs) = splitHistory hs'
|
||||
-- TODO for some mysterious reason using multithreading just for this
|
||||
-- little bit slows the program down by several seconds
|
||||
-- lift $ setNumCapabilities threads
|
||||
(CRUDOps hSs _ _ _) <- askDBState csHistStmts
|
||||
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
||||
-- lift $ setNumCapabilities 1
|
||||
-- lift $ print $ length $ lefts hSs'
|
||||
-- lift $ print $ length $ rights hSs'
|
||||
(CRUDOps hTs _ _ _) <- askDBState csHistTrans
|
||||
hTs' <- liftIOExceptT $ mapErrors readHistTransfer 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
|
||||
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
|
||||
return $ concat $ hSs' ++ hTs' ++ bTs'
|
||||
-- print $ length $ kmNewCommits state
|
||||
-- print $ length $ duOldCommits updates
|
||||
-- print $ length $ duNewTagIds updates
|
||||
|
|
@ -252,15 +254,12 @@ runSync threads c bs hs = do
|
|||
-- Update the DB.
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||
-- NOTE this must come first (unless we defer foreign keys)
|
||||
updateDBState updates
|
||||
-- TODO skip this entire section if the database won't change (eg length
|
||||
-- of 'is' is zero and there are no commits to delete)
|
||||
updateDBState
|
||||
res <- runExceptT $ do
|
||||
-- TODO taking out the hash is dumb
|
||||
(rs, ues) <- readUpdates $ fmap commitRHash rus
|
||||
-- rerunnableIO $ print ues
|
||||
-- rerunnableIO $ print $ length rs
|
||||
let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
|
||||
(CRUDOps _ bRs bUs _) <- askDBState csBudgets
|
||||
(CRUDOps _ tRs tUs _) <- askDBState csHistTrans
|
||||
(CRUDOps _ sRs sUs _) <- askDBState csHistStmts
|
||||
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
|
||||
insertAll ebs
|
||||
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
||||
-- whatever error is encountered above in an IO context, but the first
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ module Internal.Budget (readBudget) where
|
|||
import Control.Monad.Except
|
||||
import Data.Decimal hiding (allocate)
|
||||
import Data.Foldable
|
||||
import Internal.Database
|
||||
import Data.Hashable
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
|
|
@ -13,10 +13,7 @@ import qualified RIO.NonEmpty as NE
|
|||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
readBudget
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Budget
|
||||
-> m (Either CommitR [Tx CommitR])
|
||||
readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [Tx CommitR]
|
||||
readBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
|
|
@ -28,18 +25,19 @@ readBudget
|
|||
, bgtPosttax
|
||||
, bgtInterval
|
||||
} =
|
||||
eitherHash CTBudget b return $ \key -> do
|
||||
do
|
||||
spanRes <- getSpan
|
||||
case spanRes of
|
||||
Nothing -> return []
|
||||
Just budgetSpan -> do
|
||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers
|
||||
let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||
return $ txs ++ shadow
|
||||
where
|
||||
c = CommitR (hash b) CTBudget
|
||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||
pre_ = sortAllos bgtPretax
|
||||
|
|
@ -51,7 +49,7 @@ readBudget
|
|||
++ (alloAcnt <$> bgtTax)
|
||||
++ (alloAcnt <$> bgtPosttax)
|
||||
getSpan = do
|
||||
globalSpan <- askDBState kmBudgetInterval
|
||||
globalSpan <- askDBState csBudgetScope
|
||||
case bgtInterval of
|
||||
Nothing -> return $ Just globalSpan
|
||||
Just bi -> do
|
||||
|
|
@ -124,7 +122,7 @@ readIncome
|
|||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
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
|
||||
scaler <- liftExcept $ periodScaler pType' prevDay day
|
||||
let precision = cpPrec cp
|
||||
|
|
@ -138,21 +136,8 @@ readIncome
|
|||
let post =
|
||||
allocatePost precision aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
-- TODO double or rational here?
|
||||
let src =
|
||||
Entry
|
||||
{ eAcnt = srcAcnt
|
||||
, eValue = ()
|
||||
, eComment = ""
|
||||
, eTags = srcTags
|
||||
}
|
||||
let dest =
|
||||
Entry
|
||||
{ eAcnt = destAcnt
|
||||
, eValue = ()
|
||||
, eComment = "balance after deductions"
|
||||
, eTags = destTags
|
||||
}
|
||||
let src = entry0 srcAcnt "gross income" srcTags
|
||||
let dest = entry0 destAcnt "balance after deductions" destTags
|
||||
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
||||
let primary =
|
||||
EntrySet
|
||||
|
|
@ -357,11 +342,13 @@ fromShadow
|
|||
=> Tx CommitR
|
||||
-> ShadowTransfer
|
||||
-> m (Maybe ShadowEntrySet)
|
||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
|
||||
cp <- lookupCurrency stCurrency
|
||||
res <- liftExcept $ shadowMatches stMatch tx
|
||||
let es = entryPair stFrom stTo (cpID cp) stDesc stRatio ()
|
||||
return $ if not res then Nothing else Just es
|
||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
|
||||
combineErrorM curRes shaRes $ \cur sha -> do
|
||||
let es = entryPair stFrom stTo cur stDesc stRatio ()
|
||||
return $ if not sha then Nothing else Just es
|
||||
where
|
||||
curRes = lookupCurrencyKey stCurrency
|
||||
shaRes = liftExcept $ shadowMatches stMatch tx
|
||||
|
||||
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
|
||||
|
|
|
|||
|
|
@ -1,17 +1,15 @@
|
|||
module Internal.Database
|
||||
( runDB
|
||||
, readConfigState
|
||||
, nukeTables
|
||||
, updateHashes
|
||||
, updateDBState
|
||||
, getDBState
|
||||
, tree2Records
|
||||
, flattenAcntRoot
|
||||
, indexAcntRoot
|
||||
, paths2IDs
|
||||
, mkPool
|
||||
, whenHash0
|
||||
, whenHash
|
||||
, whenHash_
|
||||
, eitherHash
|
||||
, insertEntry
|
||||
, readUpdates
|
||||
, insertAll
|
||||
|
|
@ -29,7 +27,8 @@ import qualified Database.Esqueleto.Experimental as E
|
|||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||
import Database.Persist.Monad
|
||||
import Database.Persist.Sqlite hiding
|
||||
( delete
|
||||
( Statement
|
||||
, delete
|
||||
, deleteWhere
|
||||
, insert
|
||||
, insertKey
|
||||
|
|
@ -43,10 +42,11 @@ import GHC.Err
|
|||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||
import RIO.List ((\\))
|
||||
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.Text as T
|
||||
|
||||
runDB
|
||||
|
|
@ -109,6 +109,186 @@ nukeTables = do
|
|||
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
||||
-- 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 bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
where
|
||||
|
|
@ -116,22 +296,28 @@ hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
|||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
-- setDiff = setDiff' (==)
|
||||
setDiff as bs = (as \\ bs, bs \\ as)
|
||||
setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
setDiff2 = setDiffWith2 (==)
|
||||
|
||||
-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
|
||||
-- setDiff' f = go []
|
||||
-- where
|
||||
-- go inA [] bs = (inA, bs)
|
||||
-- go inA as [] = (as ++ inA, [])
|
||||
-- go inA (a:as) bs = case inB a bs of
|
||||
-- Just bs' -> go inA as bs'
|
||||
-- Nothing -> go (a:inA) as bs
|
||||
-- inB _ [] = Nothing
|
||||
-- inB a (b:bs)
|
||||
-- | f a b = Just bs
|
||||
-- | otherwise = inB a bs
|
||||
-- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
|
||||
-- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
|
||||
|
||||
-- setDiff as bs = (as \\ bs, bs \\ as)
|
||||
setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
|
||||
setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
|
||||
|
||||
setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
|
||||
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
|
||||
|
||||
getDBHashes :: MonadSqlQuery m => m [Int]
|
||||
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
||||
|
|
@ -148,42 +334,38 @@ getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
|
|||
getConfigHashes bs hs = do
|
||||
let ch = hashConfig bs hs
|
||||
dh <- getDBHashes
|
||||
return $ setDiff dh ch
|
||||
return $ setDiff2 dh ch
|
||||
|
||||
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
||||
dumpTbl = selectE $ E.from E.table
|
||||
|
||||
deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
|
||||
deleteAccount e = deleteE $ do
|
||||
c <- E.from $ E.table @AccountR
|
||||
E.where_ (c ^. AccountRId ==. E.val k)
|
||||
where
|
||||
k = entityKey e
|
||||
-- deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
|
||||
-- deleteAccount e = deleteE $ do
|
||||
-- c <- E.from $ E.table @AccountR
|
||||
-- E.where_ (c ^. AccountRId ==. E.val k)
|
||||
-- where
|
||||
-- k = entityKey e
|
||||
|
||||
deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
|
||||
deleteCurrency e = deleteE $ do
|
||||
c <- E.from $ E.table @CurrencyR
|
||||
E.where_ (c ^. CurrencyRId ==. E.val k)
|
||||
where
|
||||
k = entityKey e
|
||||
-- deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
|
||||
-- deleteCurrency e = deleteE $ do
|
||||
-- c <- E.from $ E.table @CurrencyR
|
||||
-- E.where_ (c ^. CurrencyRId ==. E.val k)
|
||||
-- where
|
||||
-- k = entityKey e
|
||||
|
||||
deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
|
||||
deleteTag e = deleteE $ do
|
||||
c <- E.from $ E.table @TagR
|
||||
E.where_ (c ^. TagRId ==. E.val k)
|
||||
where
|
||||
k = entityKey e
|
||||
-- deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
|
||||
-- deleteTag e = deleteE $ do
|
||||
-- c <- E.from $ E.table @TagR
|
||||
-- E.where_ (c ^. TagRId ==. E.val k)
|
||||
-- where
|
||||
-- k = entityKey e
|
||||
|
||||
-- TODO slip-n-slide code...
|
||||
insertFull
|
||||
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
|
||||
=> Entity r
|
||||
-> m ()
|
||||
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)
|
||||
-- -- TODO slip-n-slide code...
|
||||
-- insertFull
|
||||
-- :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
|
||||
-- => Entity r
|
||||
-- -> m ()
|
||||
-- insertFull (Entity k v) = insertKey k v
|
||||
|
||||
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
||||
currencyMap =
|
||||
|
|
@ -198,40 +380,35 @@ currencyMap =
|
|||
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
||||
toKey = toSqlKey . fromIntegral . hash
|
||||
|
||||
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
|
||||
tree2Entity t parents name des =
|
||||
Entity (toSqlKey $ fromIntegral h) $
|
||||
AccountR name (toPath parents) des (accountSign t)
|
||||
parentEntity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
|
||||
parentEntity t parents name des =
|
||||
Entity (toSqlKey $ fromIntegral h) $ AccountR name p des (accountSign t) False
|
||||
where
|
||||
p = AcntPath t (reverse (name : parents))
|
||||
p = AcntPath t (name : parents)
|
||||
h = hash p
|
||||
toPath = T.intercalate "/" . (atName t :) . reverse
|
||||
|
||||
tree2Records
|
||||
:: AcntType
|
||||
-> AccountTree
|
||||
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntType))])
|
||||
tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
|
||||
tree2Records t = go []
|
||||
where
|
||||
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
|
||||
(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
|
||||
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) =
|
||||
let e = tree2Entity t (fmap snd ps) n d
|
||||
let e = parentEntity t (fmap snd ps) n d
|
||||
k = entityKey e
|
||||
in ( [acnt k n (fmap snd ps) d]
|
||||
, expand k $ fmap fst ps
|
||||
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, t))]
|
||||
)
|
||||
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 ..]
|
||||
in ([acnt k n (fmap snd ps) d], expand k $ fmap fst ps)
|
||||
acnt k n ps desc = Entity k $ AccountR n (AcntPath t (n : ps)) desc sign True
|
||||
expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
|
||||
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 =
|
||||
uncurry zip
|
||||
|
|
@ -290,14 +467,18 @@ flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arE
|
|||
++ ((AssetT,) <$> arAssets)
|
||||
++ ((EquityT,) <$> arEquity)
|
||||
|
||||
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
|
||||
indexAcntRoot r =
|
||||
( concat ars
|
||||
, concat aprs
|
||||
, M.fromList $ paths2IDs $ concat ms
|
||||
)
|
||||
makeAcntMap :: [Entity AccountR] -> AccountMap
|
||||
makeAcntMap =
|
||||
M.fromList
|
||||
. paths2IDs
|
||||
. fmap go
|
||||
. filter (accountRLeaf . snd)
|
||||
. fmap (\e -> (E.entityKey e, E.entityVal e))
|
||||
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
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
|
|
@ -310,7 +491,7 @@ getDBState c bs hs = do
|
|||
combineError bi si $ \b s ->
|
||||
( DBState
|
||||
{ kmCurrency = currencyMap cs
|
||||
, kmAccount = am
|
||||
, kmAccount = undefined
|
||||
, kmBudgetInterval = b
|
||||
, kmStatementInterval = s
|
||||
, kmTag = tagMap ts
|
||||
|
|
@ -319,7 +500,7 @@ getDBState c bs hs = do
|
|||
, DBUpdates
|
||||
{ duOldCommits = del
|
||||
, duNewTagIds = ts
|
||||
, duNewAcntPaths = paths
|
||||
, duNewAcntPaths = undefined
|
||||
, duNewAcntIds = acnts
|
||||
, duNewCurrencyIds = cs
|
||||
}
|
||||
|
|
@ -327,7 +508,7 @@ getDBState c bs hs = do
|
|||
where
|
||||
bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
|
||||
si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
|
||||
(acnts, paths, am) = indexAcntRoot $ accounts c
|
||||
(acnts, _) = indexAcntRoot $ accounts c
|
||||
cs = currency2Record <$> currencies c
|
||||
ts = toRecord <$> tags c
|
||||
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 DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
|
||||
|
||||
updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateTags DBUpdates {duNewTagIds} = do
|
||||
tags' <- selectE $ E.from $ E.table @TagR
|
||||
let (toIns, toDel) = setDiff duNewTagIds tags'
|
||||
mapM_ deleteTag toDel
|
||||
mapM_ insertFull toIns
|
||||
-- updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
-- updateTags DBUpdates {duNewTagIds} = do
|
||||
-- tags' <- selectE $ E.from $ E.table @TagR
|
||||
-- let (toIns, toDel) = setDiff2 duNewTagIds tags'
|
||||
-- mapM_ deleteTag toDel
|
||||
-- mapM_ insertFull toIns
|
||||
|
||||
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
|
||||
acnts' <- dumpTbl
|
||||
let (toIns, toDel) = setDiff duNewAcntIds acnts'
|
||||
deleteWhere ([] :: [Filter AccountPathR])
|
||||
mapM_ deleteAccount toDel
|
||||
mapM_ insertFull toIns
|
||||
mapM_ insert duNewAcntPaths
|
||||
-- updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
-- updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
|
||||
-- acnts' <- dumpTbl
|
||||
-- let (toIns, toDel) = setDiff2 duNewAcntIds acnts'
|
||||
-- deleteWhere ([] :: [Filter AccountPathR])
|
||||
-- mapM_ deleteAccount toDel
|
||||
-- mapM_ insertFull toIns
|
||||
-- mapM_ insert duNewAcntPaths
|
||||
|
||||
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateCurrencies DBUpdates {duNewCurrencyIds} = do
|
||||
curs' <- selectE $ E.from $ E.table @CurrencyR
|
||||
let (toIns, toDel) = setDiff duNewCurrencyIds curs'
|
||||
mapM_ deleteCurrency toDel
|
||||
mapM_ insertFull toIns
|
||||
-- updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
-- updateCurrencies DBUpdates {duNewCurrencyIds} = do
|
||||
-- curs' <- selectE $ E.from $ E.table @CurrencyR
|
||||
-- let (toIns, toDel) = setDiff2 duNewCurrencyIds curs'
|
||||
-- mapM_ deleteCurrency toDel
|
||||
-- mapM_ insertFull toIns
|
||||
|
||||
updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateDBState u = do
|
||||
updateHashes u
|
||||
updateTags u
|
||||
updateAccounts u
|
||||
updateCurrencies u
|
||||
updateCD
|
||||
:: ( MonadSqlQuery m
|
||||
, PersistRecordBackend a SqlBackend
|
||||
, PersistRecordBackend b SqlBackend
|
||||
)
|
||||
=> 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 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 q = unsafeLiftSql "esqueleto-select" (E.select q)
|
||||
|
||||
whenHash
|
||||
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
|
||||
=> 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
|
||||
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
|
||||
deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q)
|
||||
|
||||
whenHash0
|
||||
:: (Hashable a, MonadFinance m)
|
||||
=> 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
|
||||
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
|
||||
insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
|
||||
|
||||
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, MonadSqlQuery m)
|
||||
-- => 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
|
||||
|
||||
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
|
||||
-- whenHash0
|
||||
-- :: (Hashable a, MonadFinance m)
|
||||
-- => 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
|
||||
-- :: (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
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
|
|
@ -457,10 +705,12 @@ readUpdates hashes = do
|
|||
)
|
||||
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
||||
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
|
||||
return (makeRE . snd <$> toRead, toUpdate')
|
||||
let toRead' = fmap (makeRE . snd) toRead
|
||||
return (toRead', toUpdate')
|
||||
where
|
||||
makeUES ((_, day, name, pri, (curID, prec)), es) = do
|
||||
let prec' = fromIntegral $ E.unValue prec
|
||||
let cur = E.unValue curID
|
||||
let res =
|
||||
bimap NE.nonEmpty NE.nonEmpty $
|
||||
NE.partition ((< 0) . entryRIndex . snd) $
|
||||
|
|
@ -477,7 +727,7 @@ readUpdates hashes = do
|
|||
Left $
|
||||
UpdateEntrySet
|
||||
{ utDate = E.unValue day
|
||||
, utCurrency = E.unValue curID
|
||||
, utCurrency = cur
|
||||
, utFrom0 = x
|
||||
, utTo0 = to0
|
||||
, utFromRO = fromRO
|
||||
|
|
@ -492,7 +742,7 @@ readUpdates hashes = do
|
|||
Right $
|
||||
UpdateEntrySet
|
||||
{ utDate = E.unValue day
|
||||
, utCurrency = E.unValue curID
|
||||
, utCurrency = cur
|
||||
, utFrom0 = x
|
||||
, utTo0 = to0
|
||||
, utFromRO = fromRO
|
||||
|
|
@ -504,7 +754,7 @@ readUpdates hashes = do
|
|||
, utPriority = E.unValue pri
|
||||
}
|
||||
_ -> throwError undefined
|
||||
makeRE ((_, day, name, pri, (curID, prec)), entry) =
|
||||
makeRE ((_, day, name, pri, (curID, prec)), entry) = do
|
||||
let e = entityVal entry
|
||||
in ReadEntry
|
||||
{ reDate = E.unValue day
|
||||
|
|
|
|||
|
|
@ -9,8 +9,8 @@ import Control.Monad.Except
|
|||
import Data.Csv
|
||||
import Data.Decimal
|
||||
import Data.Foldable
|
||||
import Data.Hashable
|
||||
import GHC.Real
|
||||
import Internal.Database
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
|
|
@ -39,10 +39,12 @@ splitHistory = partitionEithers . fmap go
|
|||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> PairedTransfer
|
||||
-> m (Either CommitR [Tx CommitR])
|
||||
readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
|
||||
bounds <- askDBState kmStatementInterval
|
||||
-> m [Tx CommitR]
|
||||
readHistTransfer ht = do
|
||||
bounds <- askDBState csHistoryScope
|
||||
expandTransfer c historyName bounds ht
|
||||
where
|
||||
c = CommitR (hash ht) CTTransfer
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
|
@ -51,11 +53,13 @@ readHistStmt
|
|||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Either CommitR [Tx CommitR])
|
||||
readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
||||
-> m [Tx CommitR]
|
||||
readHistStmt root i = do
|
||||
bs <- readImport root i
|
||||
bounds <- askDBState kmStatementInterval
|
||||
bounds <- askDBState csHistoryScope
|
||||
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?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
||||
|
|
@ -78,7 +82,7 @@ readImport_
|
|||
-> m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
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
|
||||
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
||||
Right (_, v) -> return $ catMaybes $ V.toList v
|
||||
|
|
@ -313,7 +317,7 @@ toTx
|
|||
}
|
||||
where
|
||||
curRes = do
|
||||
m <- askDBState kmCurrency
|
||||
m <- askDBState csCurrencyMap
|
||||
cur <- liftInner $ resolveCurrency m r tgCurrency
|
||||
let prec = cpPrec cur
|
||||
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
||||
|
|
@ -327,7 +331,7 @@ resolveSubGetter
|
|||
-> TxSubGetter
|
||||
-> InsertExceptT m SecondayEntrySet
|
||||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||
m <- askDBState kmCurrency
|
||||
m <- askDBState csCurrencyMap
|
||||
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
||||
let prec = cpPrec cur
|
||||
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ import RIO
|
|||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
-- TODO use newtypes for all the different numbers so they don't get mixed up
|
||||
share
|
||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
[persistLowerCase|
|
||||
|
|
@ -21,20 +22,24 @@ CommitR sql=commits
|
|||
hash Int
|
||||
type ConfigType
|
||||
deriving Show Eq Ord
|
||||
ConfigStateR sql=config_state
|
||||
historyScopeHash Int
|
||||
budgetScopeHash Int
|
||||
CurrencyR sql=currencies
|
||||
symbol T.Text
|
||||
symbol CurID
|
||||
fullname T.Text
|
||||
precision Int
|
||||
deriving Show Eq
|
||||
TagR sql=tags
|
||||
symbol T.Text
|
||||
symbol TagID
|
||||
fullname T.Text
|
||||
deriving Show Eq
|
||||
AccountR sql=accounts
|
||||
name T.Text
|
||||
fullpath T.Text
|
||||
fullpath AcntPath
|
||||
desc T.Text
|
||||
sign AcntSign
|
||||
leaf Bool
|
||||
deriving Show Eq
|
||||
AccountPathR sql=account_paths
|
||||
parent AccountRId OnDeleteCascade
|
||||
|
|
@ -70,7 +75,7 @@ TagRelationR sql=tag_relations
|
|||
deriving Show Eq
|
||||
|]
|
||||
|
||||
data ConfigType = CTBudget | CTManual | CTImport
|
||||
data ConfigType = CTBudget | CTTransfer | CTHistory
|
||||
deriving (Eq, Show, Read, Enum, Ord)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
|
|
@ -97,3 +102,38 @@ instance PersistField AcntSign where
|
|||
fromPersistValue (PersistInt64 (-1)) = Right Credit
|
||||
fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
|
||||
fromPersistValue _ = Left "not an Int64"
|
||||
|
||||
data AcntType
|
||||
= AssetT
|
||||
| EquityT
|
||||
| ExpenseT
|
||||
| IncomeT
|
||||
| LiabilityT
|
||||
deriving (Show, Eq, Ord, Hashable, Generic, Read)
|
||||
|
||||
atName :: AcntType -> T.Text
|
||||
atName AssetT = "asset"
|
||||
atName EquityT = "equity"
|
||||
atName ExpenseT = "expense"
|
||||
atName IncomeT = "income"
|
||||
atName LiabilityT = "liability"
|
||||
|
||||
data AcntPath = AcntPath
|
||||
{ apType :: !AcntType
|
||||
, apChildren :: ![T.Text]
|
||||
}
|
||||
deriving (Eq, Ord, Show, Hashable, Generic, Read)
|
||||
|
||||
instance PersistFieldSql AcntPath where
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance PersistField AcntPath where
|
||||
toPersistValue (AcntPath t cs) =
|
||||
PersistText $ T.intercalate "/" $ (atName t :) $ reverse cs
|
||||
|
||||
fromPersistValue (PersistText v) = case T.split (== '/') v of
|
||||
[] -> Left "path is empty"
|
||||
(x : xs) -> case readMaybe $ T.unpack x of
|
||||
Just t -> Right $ AcntPath t $ reverse xs
|
||||
_ -> Left "could not get account type"
|
||||
fromPersistValue _ = Left "not a string"
|
||||
|
|
|
|||
|
|
@ -371,7 +371,7 @@ data AccountRoot_ a = AccountRoot_
|
|||
, arIncome :: ![a]
|
||||
, arLiabilities :: ![a]
|
||||
}
|
||||
deriving (Generic)
|
||||
deriving (Generic, Hashable)
|
||||
|
||||
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
|
|
@ -17,7 +16,6 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
|
|||
import Dhall hiding (embed, maybe)
|
||||
import Internal.Types.Database
|
||||
import Internal.Types.Dhall
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
|
|
@ -35,6 +33,36 @@ data ConfigHashes = ConfigHashes
|
|||
, 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)
|
||||
|
||||
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
|
||||
|
|
@ -44,6 +72,23 @@ type CurrencyMap = M.Map CurID CurrencyPrec
|
|||
|
||||
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
|
||||
{ kmCurrency :: !CurrencyMap
|
||||
, kmAccount :: !AccountMap
|
||||
|
|
@ -63,8 +108,6 @@ data DBUpdates = DBUpdates
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
data DBDeferred
|
||||
= DBEntryLinked Natural Double
|
||||
| DBEntryBalance Decimal
|
||||
|
|
@ -138,35 +181,14 @@ data EntryBin
|
|||
|
||||
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
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- 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
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Decimal
|
||||
|
|
@ -178,19 +200,8 @@ data TxRecord = TxRecord
|
|||
|
||||
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)
|
||||
|
||||
-- TODO debit should be negative
|
||||
sign2Int :: AcntSign -> Int
|
||||
sign2Int Debit = 1
|
||||
sign2Int Credit = 1
|
||||
|
||||
accountSign :: AcntType -> AcntSign
|
||||
accountSign AssetT = Debit
|
||||
accountSign ExpenseT = Debit
|
||||
|
|
|
|||
|
|
@ -152,7 +152,7 @@ askDays
|
|||
-> Maybe Interval
|
||||
-> m [Day]
|
||||
askDays dp i = do
|
||||
globalSpan <- askDBState kmBudgetInterval
|
||||
globalSpan <- askDBState csBudgetScope
|
||||
case i of
|
||||
Just i' -> do
|
||||
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
|
||||
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 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
|
||||
|
||||
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 = fmap fst . lookupAccount
|
||||
|
|
@ -647,7 +639,7 @@ lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntTyp
|
|||
lookupAccountType = fmap snd . lookupAccount
|
||||
|
||||
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 = fmap cpID . lookupCurrency
|
||||
|
|
@ -656,12 +648,12 @@ lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precis
|
|||
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
||||
|
||||
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||
lookupTag = lookupFinance TagField kmTag
|
||||
lookupTag = lookupFinance TagField csTagMap
|
||||
|
||||
lookupFinance
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> EntryIDType
|
||||
-> (DBState -> M.Map T.Text a)
|
||||
-> (ConfigState -> M.Map T.Text a)
|
||||
-> T.Text
|
||||
-> m a
|
||||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
|
||||
|
|
@ -865,7 +857,7 @@ balancePrimaryEntrySet
|
|||
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
|
||||
\(f0', fs') (t0', ts') -> do
|
||||
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'
|
||||
|
||||
balanceSecondaryEntrySet
|
||||
|
|
@ -904,7 +896,7 @@ balanceFinal
|
|||
balanceFinal k@(curID, _) tot fs t0 ts = do
|
||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
|
||||
let balTo = balanceLinked fv
|
||||
ts' <- doEntries balTo k tot t0 ts
|
||||
ts' <- balanceTotalEntrySet balTo k tot t0 ts
|
||||
return $
|
||||
InsertEntrySet
|
||||
{ iesCurrency = curID
|
||||
|
|
@ -912,7 +904,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
|
|||
, iesToEntries = ts'
|
||||
}
|
||||
|
||||
doEntries
|
||||
balanceTotalEntrySet
|
||||
:: (MonadInsertError m)
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
|
||||
-> BCKey
|
||||
|
|
@ -920,7 +912,7 @@ doEntries
|
|||
-> Entry AccountRId () TagRId
|
||||
-> [Entry AccountRId v TagRId]
|
||||
-> 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
|
||||
let e0val = tot - entrySum es'
|
||||
-- TODO not dry
|
||||
|
|
|
|||
Loading…
Reference in New Issue