From fc4da967be545a8dce0460f6c72ee3ad1ac4bbdd Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 25 Jun 2023 14:26:35 -0400 Subject: [PATCH] WIP read updates from database --- lib/Internal/Database.hs | 162 ++++++++++++++++++++++++++++++++++++- lib/Internal/History.hs | 32 +++----- lib/Internal/Types/Main.hs | 7 +- lib/Internal/Utils.hs | 12 +++ 4 files changed, 188 insertions(+), 25 deletions(-) diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index a609fbf..d19f207 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -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 () diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 1856e21..4f60d17 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -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 diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index d668b26..435a2b7 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -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 diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index e64a86e..656436f 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -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