WIP read updates from database

This commit is contained in:
Nathan Dwarshuis 2023-06-25 14:26:35 -04:00
parent 05928087b2
commit fc4da967be
4 changed files with 188 additions and 25 deletions

View File

@ -11,8 +11,10 @@ module Internal.Database
, whenHash0
, whenHash
, whenHash_
, eitherHash
, insertEntry
, resolveEntry
, readUpdates
)
where
@ -20,7 +22,7 @@ import Conduit
import Control.Monad.Except
import Control.Monad.Logger
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
@ -43,6 +45,7 @@ import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as N
import qualified RIO.Text as T
import qualified RIO.Vector as V
runDB
:: MonadUnliftIO m
@ -393,6 +396,19 @@ whenHash0 t o def f = do
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 Left <$> f c else Right <$> g c
whenHash_
:: (Hashable a, MonadFinance m)
=> ConfigType
@ -438,3 +454,147 @@ resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency}
{ feCurrency = cid
, feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
}
readUpdates
:: (MonadInsertError m, MonadSqlQuery m)
=> [Int]
-> m [Either ReadEntry UpdateEntrySet]
readUpdates hashes = do
xs <- selectE $ do
(commits :& txs :& entries) <-
E.from
$ E.table @CommitR
`E.innerJoin` E.table @TransactionR
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
`E.innerJoin` E.table @EntryR
`E.on` (\(_ :& t :& e) -> t ^. TransactionRId ==. e ^. EntryRTransaction)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
return
( txs ^. TransactionRDeferred
, txs ^. TransactionRDate
, entries
)
let (toUpdate, toRead) =
bimap unpack (fmap makeRE . unpack) $
L.partition (\(d, _, _) -> E.unValue d) xs
toUpdate' <-
liftExcept $
mapErrors makeUES $
second (fmap snd) <$> groupWith uGroup toUpdate
return $ fmap Left toRead ++ fmap Right toUpdate'
where
unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
makeUES ((day, cur, _), es) = do
let (froms, tos) =
L.partition ((< 0) . entryRIndex . snd) $
L.sortOn (entryRIndex . snd) es
let tot = sum $ fmap (entryRValue . snd) froms
(from0, fromRO, fromUnk, fromVec) <- splitFrom $ reverse froms
(to0, toRO, toUnk, toLink0, toLinkN) <- splitTo fromVec tos
return
UpdateEntrySet
{ utDate = day
, utCurrency = cur
, utFrom0 = from0
, utTo0 = to0
, utFromRO = fromRO
, utToRO = toRO
, utToUnkLink0 = toLink0
, utPairs = toLinkN
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = tot
}
makeRE (d, (_, e)) =
ReadEntry
{ reDate = d
, reCurrency = entryRCurrency e
, reAcnt = entryRAccount e
, reValue = entryRValue e
}
splitFrom
:: [(EntryRId, EntryR)]
-> InsertExcept
( UpdateEntry EntryRId ()
, [UpdateEntry () Rational]
, [UpdateEntry EntryRId Rational]
, Vector (Maybe (UpdateEntry EntryRId Rational))
)
splitFrom from = do
-- ASSUME entries are sorted by index
(primary, rest) <- case from of
((i, e) : xs) -> return (makeUnkUE i e, xs)
_ -> throwError $ InsertException undefined
let rest' = fmap splitDeferredValue rest
let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
let (ro, toBal) = partitionEithers rest'
return (primary, ro, toBal, idxVec)
splitTo
:: Vector (Maybe (UpdateEntry EntryRId Rational))
-> [(EntryRId, EntryR)]
-> InsertExcept
( UpdateEntry EntryRId ()
, [UpdateEntry () Rational]
, [UpdateEntry EntryRId Rational]
, [UpdateEntry EntryRId ()]
, [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
)
splitTo froms tos = do
-- How to split the credit side of the database transaction in 1024 easy
-- steps:
--
-- 1. ASSUME the entries are sorted by index. Isolate the first as the
-- primary and puke in user's face if list is empty (which it should never
-- be)
(primary, rest) <- case tos of
((i, e) : xs) -> return (makeUnkUE i e, xs)
_ -> throwError $ InsertException undefined
-- 1. Split the entries based on if they have a link
let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
-- 2. Split unlinked based on if they have a balance target
let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked
-- 3. Split paired entries by link == 0 (which are special) or link > 0
let (paired0, pairedN) =
bimap (fmap (uncurry makeUnkUE . snd)) (groupKey id) $
L.partition ((== 0) . fst) linked
-- 4. Group linked entries (which now have links > 0) according to the debit
-- entry to which they are linked. If the debit entry cannot be found or
-- if the linked entry has no scale, blow up in user's face. If the
-- debit entry is read-only (signified by Nothing in the 'from' array)
-- then consider the linked entry as another credit read-only entry
(pairedUnk, pairedRO) <- partitionEithers <$> mapErrors splitPaired pairedN
return (primary, ro ++ concat pairedRO, toBal, paired0, pairedUnk)
where
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
Nothing -> throwError $ InsertException undefined
makeLinkUnk (k, e) =
maybe
(throwError $ InsertException undefined)
(return . makeUE k e)
$ entryRDeferred_value e
splitDeferredValue
:: (EntryRId, EntryR)
-> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
splitDeferredValue (k, e) =
maybe (Left $ makeRoUE e) (Right . makeUE k e) $ entryRDeferred_value e
makeUE :: i -> EntryR -> v -> UpdateEntry i v
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
makeRoUE :: EntryR -> UpdateEntry () Rational
makeRoUE e = makeUE () e (entryRValue e)
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
makeUnkUE k e = makeUE k e ()

View File

@ -56,22 +56,12 @@ readHistTransfer
return $ fmap tx days
concat <$> mapErrors go amts
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
groupKey f = fmap go . NE.groupAllWith (f . fst)
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m [DeferredTx CommitR]
readHistStmt root i = whenHash0 CTImport i [] $ \c -> do
-> m (Either CommitR [DeferredTx CommitR])
readHistStmt root i = eitherHash CTImport i return $ \c -> do
bs <- readImport root i
bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
@ -84,11 +74,11 @@ splitHistory = partitionEithers . fmap go
insertHistory
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [DeferredTx CommitR]
=> [EntryBin]
-> m ()
insertHistory hs = do
bs <- balanceTxs hs
forM_ (groupWith txCommit bs) $ \(c, ts) -> do
(toUpdate, toInsert) <- balanceTxs hs
forM_ (groupWith txCommit toInsert) $ \(c, ts) -> do
ck <- insert c
mapM_ (insertTx ck) ts
@ -456,13 +446,13 @@ balanceEntrySet
doEntries
:: (MonadInsertError m, MonadFinance m)
=> (Int -> Entry AcntID v TagID -> State EntryBals (FullEntry AccountRId CurrencyRId TagID))
=> (Int -> Entry AcntID v t -> State EntryBals (FullEntry AccountRId CurrencyRId t))
-> CurrencyRId
-> Rational
-> Entry AcntID () TagID
-> [Entry AcntID v TagID]
-> Entry AcntID () t
-> [Entry AcntID v t]
-> NonEmpty Int
-> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagID]
-> StateT EntryBals m [FullEntry AccountRId CurrencyRId t]
doEntries f curID tot e es (i0 :| iN) = do
es' <- liftInnerS $ mapM (uncurry f) $ zip iN es
let val0 = tot - entrySum es'
@ -505,8 +495,8 @@ balanceEntry
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-> CurrencyRId
-> Int
-> Entry AcntID v TagID
-> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagID)
-> Entry AcntID v t
-> StateT EntryBals m (FullEntry AccountRId CurrencyRId t)
balanceEntry f curID index e@Entry {eValue, eAcnt} = do
(acntID, sign, _) <- lookupAccount eAcnt
let s = fromIntegral $ sign2Int sign

View File

@ -80,11 +80,12 @@ data UpdateEntry i v = UpdateEntry
data UpdateEntrySet = UpdateEntrySet
{ utFrom0 :: !(UpdateEntry EntryRId ())
, utTo0 :: !(UpdateEntry EntryRId ())
, utPairs :: ![(UpdateEntry EntryRId Rational, UpdateEntry EntryRId ())]
, -- for these two, the Rational number is the balance target (not the
, -- for these next three, the Rational number is the balance target (not the
-- value of the account)
utFromUnk :: ![UpdateEntry EntryRId Rational]
utPairs :: ![(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
, utFromUnk :: ![UpdateEntry EntryRId Rational]
, utToUnk :: ![UpdateEntry EntryRId Rational]
, utToUnkLink0 :: ![UpdateEntry EntryRId ()]
, utFromRO :: ![UpdateEntry () Rational]
, utToRO :: ![UpdateEntry () Rational]
, utCurrency :: !CurrencyRId

View File

@ -58,6 +58,8 @@ module Internal.Utils
, lookupCurrencyPrec
, lookupTag
, mapAdd_
, groupKey
, groupWith
)
where
@ -1007,6 +1009,16 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
-- where
-- go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
groupKey f = fmap go . NE.groupAllWith (f . fst)
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k