WIP add code to actually insert updates in the db

lib/Internal/History.hs

@@ -9,6 +9,7 @@ where
 import Control.Monad.Except
 import Data.Csv
 import Data.Foldable
+import Database.Persist ((=.))
 import Database.Persist.Monad hiding (get)
 import Internal.Database
 import Internal.Types.Main
@@ -78,9 +79,11 @@ insertHistory
   -> m ()
 insertHistory hs = do
   (toUpdate, toInsert) <- balanceTxs hs
-  forM_ (groupWith txCommit toInsert) $ \(c, ts) -> do
+  mapM_ updateTx toUpdate
-    ck <- insert c
+  forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $
-    mapM_ (insertTx ck) ts
+    \(c, ts) -> do
+      ck <- insert $ c
+      mapM_ (insertTx ck) ts
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
@@ -128,6 +131,9 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
   k <- insert $ TransactionR c d e anyDeferred
   mapM_ (insertEntry k) ss
 
+updateTx :: MonadSqlQuery m => UEBalanced -> m ()
+updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. (unEntryValue ueValue)]
+
 --------------------------------------------------------------------------------
 -- Statements
 
@@ -334,14 +340,14 @@ balanceTxs
   -> m ([UEBalanced], [KeyTx CommitR])
 balanceTxs es =
   (first concat . partitionEithers . catMaybes)
-    <$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
+    <$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty
   where
-    go (ToUpdate utx) = (Just . Left) <$> rebalanceEntrySet utx
+    go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
       modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
     go (ToInsert (t@Tx {txEntries, txDate})) =
-      (\es -> Just $ Right $ t {txEntries = concat es})
+      (\es' -> Just $ Right $ t {txEntries = concat es'})
         <$> mapM (balanceEntrySet txDate) txEntries
 
 binDate :: EntryBin -> Day
@@ -372,7 +378,7 @@ rebalanceEntrySet
     } =
     do
       let fs =
-            L.sortOn index $
+            L.sortOn idx $
               (UET_ReadOnly <$> utFromRO)
                 ++ (UET_Balance <$> utFromUnk)
                 ++ (UET_Linked <$> utPairs)
@@ -380,11 +386,12 @@ rebalanceEntrySet
       let f0val = utTotalValue - (sum $ fmap value fs')
       let f0 = utFrom0 {ueValue = EntryValue f0val}
       let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
+      let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
       let ts =
-            (UET_Linked <$> tpairs)
+            L.sortOn idx2 $
-              ++ (UET_Balance <$> utToUnk)
+              (UET_Linked <$> (tpairs ++ tsLink0))
-              ++ (UET_ReadOnly <$> utToRO)
+                ++ (UET_Balance <$> utToUnk)
-      let tsLink0 = fmap (\e -> e {ueValue = -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
+                ++ (UET_ReadOnly <$> utToRO)
       (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
       let t0val =
             (EntryValue utTotalValue)
@@ -395,7 +402,8 @@ rebalanceEntrySet
       project f _ _ (UET_ReadOnly e) = f e
       project _ f _ (UET_Balance e) = f e
       project _ _ f (UET_Linked p) = f p
-      index = project ueIndex ueIndex (ueIndex . fst)
+      idx = project ueIndex ueIndex (ueIndex . fst)
+      idx2 = project ueIndex ueIndex ueIndex
       value =
         project
           (unEntryValue . ueValue)
@@ -455,8 +463,8 @@ balanceEntrySet
 
       -- resolve accounts and balance debit entries since we need an array
       -- of debit entries for linked credit entries later
-      let balFromEntry = balanceEntry (balanceDeferred curID) curID
+      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
-      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (-1) (-1))
+      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1))
       let fv = V.fromList $ fmap (eValue . feEntry) fs'
 
       -- finally resolve credit entries
@@ -466,15 +474,15 @@ balanceEntrySet
 
 doEntries
   :: (MonadInsertError m, MonadFinance m)
-  => (Int -> Entry AcntID v t -> State EntryBals (FullEntry AccountRId CurrencyRId t))
+  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId))
   -> CurrencyRId
   -> Rational
-  -> Entry AcntID () t
+  -> Entry AcntID () TagID
-  -> [Entry AcntID v t]
+  -> [Entry AcntID v TagID]
   -> NonEmpty Int
-  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId t]
+  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
 doEntries f curID tot e es (i0 :| iN) = do
-  es' <- liftInnerS $ mapM (uncurry f) $ zip iN es
+  es' <- mapM (uncurry f) $ zip iN es
   let val0 = tot - entrySum es'
   e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
   return $ e' : es'
@@ -485,19 +493,20 @@ liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
 liftInnerS = mapStateT (return . runIdentity)
 
 balanceLinked
-  :: Vector Rational
+  :: MonadInsertError m
+  => Vector Rational
   -> CurrencyRId
   -> Natural
   -> AccountRId
   -> LinkDeferred Rational
-  -> StateT EntryBals Identity (Rational, Maybe DBDeferred)
+  -> StateT EntryBals m (Rational, Maybe DBDeferred)
 balanceLinked from curID precision acntID lg = case lg of
-  (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) -> do
+  (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
     let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
     case res of
       Just v -> return $ (v, Just $ EntryLinked lngIndex $ toRational lngScale)
       Nothing -> throwError undefined
-  (LinkDeferred d) -> balanceDeferred curID acntID d
+  (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
   where
     go s = roundPrecision precision . (* s) . fromRational
 
@@ -515,22 +524,22 @@ balanceEntry
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
   -> Int
-  -> Entry AcntID v t
+  -> Entry AcntID v TagID
-  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId t)
+  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)
-balanceEntry f curID index e@Entry {eValue, eAcnt} = do
+balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
-  (acntID, sign, _) <- lookupAccount eAcnt
+  let acntRes = lookupAccount eAcnt
-  let s = fromIntegral $ sign2Int sign
+  let tagRes = mapErrors lookupTag eTags
-  (newVal, deferred) <- f acntID eValue
+  combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
-  modify (mapAdd_ (acntID, curID) newVal)
+    let s = fromIntegral $ sign2Int sign
-  return $
+    (newVal, deferred) <- f acntID eValue
-    FullEntry
+    modify (mapAdd_ (acntID, curID) newVal)
-      { feEntry = e {eValue = s * newVal, eAcnt = acntID}
+    return $
-      , feCurrency = curID
+      FullEntry
-      , feDeferred = deferred
+        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
-      , feIndex = index
+        , feCurrency = curID
-      }
+        , feDeferred = deferred
-  where
+        , feIndex = idx
-    key = (eAcnt, curID)
+        }
 
 findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
 findBalance acnt cur toBal v = do