WIP add code to actually insert updates in the db

lib/Internal/Database.hs

@@ -516,12 +516,7 @@ readUpdates hashes = do
 
 splitFrom
   :: [(EntryRId, EntryR)]
-  -> InsertExcept
-      ( UpdateEntry EntryRId ()
-      , [UpdateEntry () Rational]
-      , [UpdateEntry EntryRId Rational]
-      , Vector (Maybe (UpdateEntry EntryRId Rational))
-      )
+  -> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance))
 splitFrom from = do
   -- ASSUME entries are sorted by index
   (primary, rest) <- case from of
@@ -533,14 +528,14 @@ splitFrom from = do
   return (primary, ro, toBal, idxVec)
 
 splitTo
-  :: Vector (Maybe (UpdateEntry EntryRId Rational))
+  :: Vector (Maybe UEBalance)
   -> [(EntryRId, EntryR)]
   -> InsertExcept
-      ( UpdateEntry EntryRId ()
-      , [UpdateEntry () Rational]
-      , [UpdateEntry EntryRId Rational]
-      , [UpdateEntry EntryRId ()]
-      , [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
+      ( UEBlank
+      , [UE_RO]
+      , [UEBalance]
+      , [UELink]
+      , [(UEBalance, [UELink])]
       )
 splitTo froms tos = do
   -- How to split the credit side of the database transaction in 1024 easy
@@ -560,18 +555,18 @@ splitTo froms tos = do
   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
+  let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
+  let paired0Res = mapErrors (makeLinkUnk . snd) paired0
 
   -- 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
+  let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
 
-  return (primary, ro ++ concat pairedRO, toBal, paired0, pairedUnk)
+  combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) ->
+    (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
@@ -581,20 +576,19 @@ splitTo froms tos = do
     makeLinkUnk (k, e) =
       maybe
         (throwError $ InsertException undefined)
-        (return . makeUE k e)
+        (return . makeUE k e . LinkScale)
         $ entryRDeferred_value e
 
-splitDeferredValue
-  :: (EntryRId, EntryR)
-  -> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
+splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
 splitDeferredValue (k, e) =
-  maybe (Left $ makeRoUE e) (Right . makeUE k e) $ entryRDeferred_value e
+  maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . 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)
+makeRoUE :: EntryR -> UpdateEntry () EntryValue
+makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()

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
-    ck <- insert c
-    mapM_ (insertTx ck) ts
+  mapM_ updateTx toUpdate
+  forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $
+    \(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
 
@@ -331,17 +337,17 @@ matchNonDates ms = go ([], [], initZipper ms)
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
   => [EntryBin]
-  -> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR])
+  -> 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
@@ -352,11 +358,11 @@ binDate (ToInsert (Tx {txDate})) = txDate
 type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
 data UpdateEntryType a
-  = UEReadOnly (UpdateEntry () Rational)
-  | UEBlank (UpdateEntry EntryRId Rational)
-  | UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a)
+  = UET_ReadOnly UE_RO
+  | UET_Balance UEBalance
+  | UET_Linked a
 
-rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational]
+rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceEntrySet
   UpdateEntrySet
     { utFrom0
@@ -367,53 +373,75 @@ rebalanceEntrySet
     , utFromRO
     , utToRO
     , utCurrency
+    , utToUnkLink0
     , utTotalValue
     } =
     do
       let fs =
-            L.sortOn index $
-              (UEReadOnly <$> utFromRO)
-                ++ (UEBlank <$> utFromUnk)
-                ++ (UEPaired <$> utPairs)
+            L.sortOn idx $
+              (UET_ReadOnly <$> utFromRO)
+                ++ (UET_Balance <$> utFromUnk)
+                ++ (UET_Linked <$> utPairs)
       fs' <- mapM goFrom fs
-      let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')}
-      let (fs'', tpairs) = partitionEithers $ concatMap flatten fs'
-      let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO)
+      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 =
+            L.sortOn idx2 $
+              (UET_Linked <$> (tpairs ++ tsLink0))
+                ++ (UET_Balance <$> utToUnk)
+                ++ (UET_ReadOnly <$> utToRO)
       (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
-      let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))}
-      return $ f0 : fs'' ++ t0 : tsUnk
+      let t0val =
+            (EntryValue utTotalValue)
+              - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))
+      let t0 = utTo0 {ueValue = t0val}
+      return $ (f0 : (fmap (fmap (EntryValue . unBalanceTarget)) fs'')) ++ (t0 : tsUnk)
     where
-      project f _ _ (UEReadOnly e) = f e
-      project _ f _ (UEBlank e) = f e
-      project _ _ f (UEPaired p) = f p
-      index = project ueIndex ueIndex (ueIndex . fst)
-      value = project ueValue ueValue (ueValue . fst)
-      flatten = project (const []) ((: []) . Right) (\(a, b) -> [Right a, Left b])
+      project f _ _ (UET_ReadOnly e) = f e
+      project _ f _ (UET_Balance e) = f e
+      project _ _ f (UET_Linked p) = f p
+      idx = project ueIndex ueIndex (ueIndex . fst)
+      idx2 = project ueIndex ueIndex ueIndex
+      value =
+        project
+          (unEntryValue . ueValue)
+          (unBalanceTarget . ueValue)
+          (unBalanceTarget . ueValue . fst)
+      flatten = project (const []) ((: []) . Right) (\(a, bs) -> (Right a) : (Left <$> bs))
       -- TODO the following is wetter than the average groupie
-      goFrom (UEReadOnly e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
-        return $ UEReadOnly e
-      goFrom (UEBlank e) = do
+      goFrom (UET_ReadOnly e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
+        return $ UET_ReadOnly e
+      goFrom (UET_Balance e) = do
         let key = (ueAcnt e, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = ueValue e - curBal
+        let newVal = unBalanceTarget (ueValue e) - curBal
         modify $ mapAdd_ key newVal
-        return $ UEBlank $ e {ueValue = newVal}
-      goFrom (UEPaired (e0, e1)) = do
+        return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
+      goFrom (UET_Linked (e0, es)) = do
         let key = (ueAcnt e0, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = ueValue e0 - curBal
+        let newVal = unBalanceTarget (ueValue e0) - curBal
         modify $ mapAdd_ key newVal
-        return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal})
-      goTo (Left e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
+        return $
+          UET_Linked $
+            ( e0 {ueValue = BalanceTarget newVal}
+            , fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es
+            )
+      goTo (UET_ReadOnly e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
         return $ Left e
-      goTo (Right e) = do
+      goTo (UET_Linked e) = do
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
+        return $ Right e
+      goTo (UET_Balance e) = do
         let key = (ueAcnt e, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = ueValue e - curBal
+        let newVal = unBalanceTarget (ueValue e) - curBal
         modify $ mapAdd_ key newVal
-        return $ Right $ e {ueValue = newVal}
+        return $ Right $ e {ueValue = EntryValue newVal}
 
 balanceEntrySet
   :: (MonadInsertError m, MonadFinance m)
@@ -435,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
-      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (-1) (-1))
+      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
+      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1))
       let fv = V.fromList $ fmap (eValue . feEntry) fs'
 
       -- finally resolve credit entries
@@ -446,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 v t]
+  -> Entry AcntID () TagID
+  -> [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'
@@ -465,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
 
@@ -495,22 +524,22 @@ balanceEntry
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
   -> Int
-  -> 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
-  (newVal, deferred) <- f acntID eValue
-  modify (mapAdd_ (acntID, curID) newVal)
-  return $
-    FullEntry
-      { feEntry = e {eValue = s * newVal, eAcnt = acntID}
-      , feCurrency = curID
-      , feDeferred = deferred
-      , feIndex = index
-      }
-  where
-    key = (eAcnt, curID)
+  -> Entry AcntID v TagID
+  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)
+balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
+  let acntRes = lookupAccount eAcnt
+  let tagRes = mapErrors lookupTag eTags
+  combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
+    let s = fromIntegral $ sign2Int sign
+    (newVal, deferred) <- f acntID eValue
+    modify (mapAdd_ (acntID, curID) newVal)
+    return $
+      FullEntry
+        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
+        , feCurrency = curID
+        , feDeferred = deferred
+        , feIndex = idx
+        }
 
 findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
 findBalance acnt cur toBal v = do

lib/Internal/Types/Main.hs

@@ -77,17 +77,36 @@ data UpdateEntry i v = UpdateEntry
   , ueIndex :: !Int -- TODO this isn't needed for primary entries
   }
 
+deriving instance Functor (UpdateEntry i)
+
+newtype LinkScale = LinkScale {unLinkScale :: Rational}
+  deriving newtype (Num)
+
+newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
+  deriving newtype (Num)
+
+newtype EntryValue = EntryValue {unEntryValue :: Rational}
+  deriving newtype (Num)
+
+type UEBalance = UpdateEntry EntryRId BalanceTarget
+
+type UELink = UpdateEntry EntryRId LinkScale
+
+type UEBlank = UpdateEntry EntryRId ()
+
+type UE_RO = UpdateEntry () EntryValue
+
+type UEBalanced = UpdateEntry EntryRId EntryValue
+
 data UpdateEntrySet = UpdateEntrySet
-  { utFrom0 :: !(UpdateEntry EntryRId ())
-  , utTo0 :: !(UpdateEntry EntryRId ())
-  , -- for these next three, the Rational number is the balance target (not the
-    -- value of the account)
-    utPairs :: ![(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
-  , utFromUnk :: ![UpdateEntry EntryRId Rational]
-  , utToUnk :: ![UpdateEntry EntryRId Rational]
-  , utToUnkLink0 :: ![UpdateEntry EntryRId ()]
-  , utFromRO :: ![UpdateEntry () Rational]
-  , utToRO :: ![UpdateEntry () Rational]
+  { utFrom0 :: !UEBlank
+  , utTo0 :: !UEBlank
+  , utPairs :: ![(UEBalance, [UELink])]
+  , utFromUnk :: ![UEBalance]
+  , utToUnk :: ![UEBalance]
+  , utToUnkLink0 :: ![UELink]
+  , utFromRO :: ![UE_RO]
+  , utToRO :: ![UE_RO]
   , utCurrency :: !CurrencyRId
   , utDate :: !Day
   , utTotalValue :: !Rational