WIP read updates from database
This commit is contained in:
parent
05928087b2
commit
fc4da967be
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue