WIP read updates from database

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 ()

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]
+  -> m (Either CommitR [DeferredTx CommitR])
-readHistStmt root i = whenHash0 CTImport i [] $ \c -> do
+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
+  (toUpdate, toInsert) <- balanceTxs hs
-  forM_ (groupWith txCommit bs) $ \(c, ts) -> do
+  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 () t
-  -> [Entry AcntID v TagID]
+  -> [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
+  -> Entry AcntID v t
-  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagID)
+  -> 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

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 next three, the Rational number is the balance target (not the
-  , -- for these two, 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

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