Merge #2010

2010: Yet another fix for reported withdrawals in transactions + underflow in case of key deposit reclaim r=KtorZ a=KtorZ

# Issue Number

<!-- Put here a reference to the issue this PR relates to and which requirements it tackles -->

#2009 + TODO


# Overview

<!-- Detail in a few bullet points the work accomplished in this PR -->

- 5757a55
  📍 **highlight reported failure in integration scenarios by adding more assertions**
  
- d5b4335
  📍 **report our withdrawals differently from external withdrawals.**
    We haven't been quite careful here when introducing the reward redemption and the transaction amount are looking weird again.
  This commit fixes several issues:

  1. It only counts withdrawals on the "spent" side of the balance if they are coming from OUR reward account. Indeed, in the case of external withdrawals, the money is coming from elsewhere and not from the wallet itself.

  2. Fix an underflow in the amount calculation in the case where we spent less than we receive. This can be the case when:
    a. We are redeeming from an external account and the reward brings more than the fee. From the redeeming wallet, it'll look like the wallet is receiving money.
    b. We are reclaiming a key deposit back, and it brings more money than what's actually spent.

  3. Discover transactions that are spending our withdrawals without belonging to our wallet. This happens when the reward is redeemed from another wallet. That transaction should still show up in the redeemed wallet, without which rewards would just "vanish" without any trace reported by the wallet.

# Comments

<!-- Additional comments or screenshots to attach if any -->

<!-- 
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Once created, link this PR to its corresponding ticket
 ✓ Assign the PR to a corresponding milestone
 ✓ Acknowledge any changes required to the Wiki
-->


Co-authored-by: KtorZ <matthias.benkort@gmail.com>

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs

@@ -1301,13 +1301,20 @@ spec = do
                 }],
                 "passphrase": #{fixturePassphrase}
             }|]
+        let fee = 143600
+
         rTx <- request @(ApiTransaction n) ctx
             (Link.createTransaction @'Shelley wSelf) Default payload
         verify rTx
             [ expectResponseCode HTTP.status202
             , expectField #withdrawals
                 (`shouldSatisfy` (not . null))
+            , expectField (#direction . #getApiT)
+                (`shouldBe` Incoming)
+            , expectField (#amount . #getQuantity)
+                (`shouldBe` (oneMillionAda - fee))
             ]
+        let tid = getFromResponse Prelude.id rTx
 
         eventually "rewards disappear from other" $ do
             rWOther <- request @ApiWallet ctx
@@ -1317,6 +1324,20 @@ spec = do
                     (`shouldBe` Quantity 0)
                 ]
 
+        eventually "withdrawal transaction is listed on other" $ do
+            rTxOther <- request @(ApiTransaction n) ctx
+                (Link.getTransaction  @'Shelley wOther tid) Default payload
+            verify rTxOther
+                [ expectResponseCode
+                    HTTP.status200
+                , expectField #withdrawals
+                    (`shouldSatisfy` (not . null))
+                , expectField (#direction . #getApiT)
+                    (`shouldBe` Outgoing)
+                , expectField (#amount . #getQuantity)
+                    (`shouldBe` oneMillionAda)
+                ]
+
         eventually "rewards appear on self" $ do
             rWSelf <- request @ApiWallet ctx
                 (Link.getWallet @'Shelley wSelf) Default payload
@@ -1325,6 +1346,22 @@ spec = do
                     (.> (wSelf ^. #balance . #getApiT . #available))
                 ]
 
+        eventually "withdrawal transaction is listed on self" $ do
+            rTxSelf <- request @(ApiTransaction n) ctx
+                (Link.getTransaction  @'Shelley wSelf tid) Default payload
+            verify rTxSelf
+                [ expectResponseCode
+                    HTTP.status200
+                , expectField #withdrawals
+                    (`shouldSatisfy` (not . null))
+                , expectField (#direction . #getApiT)
+                    (`shouldBe` Incoming)
+                , expectField (#amount . #getQuantity)
+                    (`shouldBe` (oneMillionAda - fee))
+                , expectField (#status . #getApiT)
+                    (`shouldBe` InLedger)
+                ]
+
     it "SHELLEY_TX_REDEEM_03 - Can't redeem rewards from other if none left" $ \ctx -> do
         (wOther, mw) <- rewardWallet ctx
         wSelf  <- fixtureWallet ctx

lib/core/src/Cardano/Wallet.hs

@@ -308,6 +308,7 @@ import Cardano.Wallet.Primitive.Types
     , WalletName (..)
     , WalletPassphraseInfo (..)
     , computeUtxoStatistics
+    , distance
     , dlgCertPoolId
     , fromTransactionInfo
     , log10
@@ -1511,6 +1512,7 @@ signPayment
         ( HasTransactionLayer t k ctx
         , HasDBLayer s k ctx
         , HasNetworkLayer t ctx
+        , IsOurs s ChimericAccount
         , IsOwned s k
         , GenChange s
         )
@@ -1538,7 +1540,7 @@ signPayment ctx wid argGenChange mkRewardAccount pwd cs = db & \DBLayer{..} -> d
             (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
                 mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) cs'
 
-            (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' cs'
+            (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' tx cs'
             return (tx, meta, time, sealedTx)
   where
     ti :: TimeInterpreter IO
@@ -1553,6 +1555,7 @@ signTx
         ( HasTransactionLayer t k ctx
         , HasDBLayer s k ctx
         , HasNetworkLayer t ctx
+        , IsOurs s ChimericAccount
         , IsOwned s k
         , HardDerivation k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
@@ -1577,7 +1580,7 @@ signTx ctx wid pwd (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do
             (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
                 mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) cs
 
-            (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) (getState cp) cs
+            (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) (getState cp) tx cs
             return (tx, meta, time, sealedTx)
   where
     ti :: TimeInterpreter IO
@@ -1639,6 +1642,7 @@ signDelegation
         , HasDBLayer s k ctx
         , HasNetworkLayer t ctx
         , IsOwned s k
+        , IsOurs s ChimericAccount
         , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
@@ -1689,7 +1693,7 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
                             coinSel'
 
             (time, meta) <- liftIO $
-                mkTxMeta ti (currentTip cp) s' coinSel'
+                mkTxMeta ti (currentTip cp) s' tx coinSel'
             return (tx, meta, time, sealedTx)
   where
     ti :: TimeInterpreter IO
@@ -1700,42 +1704,53 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
 
 -- | Construct transaction metadata from a current block header and a list
 -- of input and output.
+--
+-- FIXME: There's a logic duplication regarding the calculation of the transaction
+-- amount between right here, and the Primitive.Model (see prefilterBlocks).
 mkTxMeta
-    :: (IsOurs s Address, Monad m)
+    :: (IsOurs s Address, IsOurs s ChimericAccount, Monad m)
     => TimeInterpreter m
     -> BlockHeader
     -> s
+    -> Tx
     -> CoinSelection
     -> m (UTCTime, TxMeta)
-mkTxMeta interpretTime blockHeader wState cs =
+mkTxMeta interpretTime blockHeader wState tx cs =
     let
         amtOuts =
             sum (mapMaybe ourCoins (outputs cs))
 
-        amtInps = fromIntegral $
-            sum (getCoin . coin . snd <$> (inputs cs))
-            + withdrawal cs
-            + reclaim cs
+        amtInps
+            = sum (fromIntegral . getCoin . coin . snd <$> (inputs cs))
+            + sum (mapMaybe ourWithdrawal $ Map.toList $ withdrawals tx)
+            + fromIntegral (reclaim cs)
     in do
         t <- slotStartTime' (blockHeader ^. #slotNo)
         return
             ( t
             , TxMeta
                 { status = Pending
-                , direction = Outgoing
+                , direction = if amtInps > amtOuts then Outgoing else Incoming
                 , slotNo = blockHeader ^. #slotNo
                 , blockHeight = blockHeader ^. #blockHeight
-                , amount = Quantity (amtInps - amtOuts)
+                , amount = Quantity $ distance amtInps amtOuts
                 }
             )
   where
     slotStartTime' = interpretTime . startTime
+
     ourCoins :: TxOut -> Maybe Natural
     ourCoins (TxOut addr (Coin val)) =
         if fst (isOurs addr wState)
         then Just (fromIntegral val)
         else Nothing
 
+    ourWithdrawal :: (ChimericAccount, Coin) -> Maybe Natural
+    ourWithdrawal (acct, (Coin val)) =
+        if fst (isOurs acct wState)
+        then Just (fromIntegral val)
+        else Nothing
+
 -- | Broadcast a (signed) transaction to the network.
 submitTx
     :: forall ctx s t k.
@@ -1861,6 +1876,7 @@ joinStakePool
         , HasNetworkLayer t ctx
         , HasTransactionLayer t k ctx
         , IsOwned s k
+        , IsOurs s ChimericAccount
         , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
@@ -1918,6 +1934,7 @@ quitStakePool
         , HasNetworkLayer t ctx
         , HasTransactionLayer t k ctx
         , IsOwned s k
+        , IsOurs s ChimericAccount
         , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -646,6 +646,7 @@ mkShelleyWallet
         ( ctx ~ ApiLayer s t k
         , s ~ SeqState n k
         , IsOurs s Address
+        , IsOurs s ChimericAccount
         , HasWorkerRegistry s k ctx
         )
     => MkApiWallet ctx s ApiWallet
@@ -753,6 +754,7 @@ mkLegacyWallet
         , KnownDiscovery s
         , HasNetworkLayer t ctx
         , IsOurs s Address
+        , IsOurs s ChimericAccount
         )
     => ctx
     -> WalletId
@@ -1205,6 +1207,7 @@ postTransaction
         ( Buildable (ErrValidateSelection t)
         , GenChange s
         , HasNetworkLayer t ctx
+        , IsOurs s ChimericAccount
         , IsOwned s k
         , ctx ~ ApiLayer s t k
         , HardDerivation k
@@ -1373,6 +1376,7 @@ joinStakePool
     :: forall ctx s t n k.
         ( DelegationAddress n k
         , s ~ SeqState n k
+        , IsOurs s ChimericAccount
         , IsOwned s k
         , GenChange s
         , HardDerivation k
@@ -1435,6 +1439,7 @@ quitStakePool
     :: forall ctx s t n k.
         ( DelegationAddress n k
         , s ~ SeqState n k
+        , IsOurs s ChimericAccount
         , IsOwned s k
         , GenChange s
         , HasNetworkLayer t ctx
@@ -1499,7 +1504,8 @@ getMigrationInfo ctx (ApiT wid) = do
 
 migrateWallet
     :: forall s t k n p.
-        ( IsOwned s k
+        ( IsOurs s ChimericAccount
+        , IsOwned s k
         , HardDerivation k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
         , PaymentAddress n ByronKey

lib/core/src/Cardano/Wallet/Primitive/Model.hs

@@ -72,6 +72,7 @@ import Cardano.Wallet.Primitive.Types
     , TxStatus (..)
     , UTxO (..)
     , balance
+    , distance
     , dlgCertAccount
     , excluding
     , inputs
@@ -291,18 +292,22 @@ availableBalance pending =
 
 -- | Total balance = 'balance' . 'totalUTxO' +? rewards
 totalBalance
-    :: IsOurs s Address
+    :: (IsOurs s Address, IsOurs s ChimericAccount)
     => Set Tx
     -> Quantity "lovelace" Natural
     -> Wallet s
     -> Natural
-totalBalance pending (Quantity rewards) s =
-    balance (totalUTxO pending s) + if hasPendingWithdrawals then 0 else rewards
+totalBalance pending (Quantity rewards) wallet@(Wallet _ _ s _) =
+    balance (totalUTxO pending wallet) +
+        if hasPendingWithdrawals pending
+        then 0
+        else rewards
   where
     hasPendingWithdrawals =
-        not $ Set.null $ Set.filter
-            (not . Map.null . withdrawals)
-            pending
+        anyS (anyM (\acct _ -> fst (isOurs acct s)) . withdrawals)
+      where
+        anyS predicate = not . Set.null . Set.filter predicate
+        anyM predicate = not . Map.null . Map.filterWithKey predicate
 
 -- | Available UTxO = @pending ⋪ utxo@
 availableUTxO
@@ -365,6 +370,14 @@ prefilterBlock b u0 = runState $ do
         state (isOurs $ dlgCertAccount cert) <&> \case
             False -> Nothing
             True -> Just cert
+    ourWithdrawal
+        :: IsOurs s ChimericAccount
+        => (ChimericAccount, Coin)
+        -> State s (Maybe (ChimericAccount, Coin))
+    ourWithdrawal (acct, amt) =
+        state (isOurs acct) <&> \case
+            False -> Nothing
+            True  -> Just (acct, amt)
     mkTxMeta :: Natural -> Direction -> TxMeta
     mkTxMeta amt dir = TxMeta
         { status = InLedger
@@ -374,25 +387,28 @@ prefilterBlock b u0 = runState $ do
         , amount = Quantity amt
         }
     applyTx
-        :: (IsOurs s Address)
+        :: (IsOurs s Address, IsOurs s ChimericAccount)
         => ([(Tx, TxMeta)], UTxO)
         -> Tx
         -> State s ([(Tx, TxMeta)], UTxO)
     applyTx (!txs, !u) tx = do
         ourU <- state $ utxoOurs tx
         let ourIns = Set.fromList (inputs tx) `Set.intersection` dom (u <> ourU)
         let u' = (u <> ourU) `excluding` ourIns
-        let wdrls = fromIntegral . getCoin <$> Map.elems (withdrawals tx)
+        ourWithdrawals <- fmap (fromIntegral . getCoin . snd) <$>
+            mapMaybeM ourWithdrawal (Map.toList $ withdrawals tx)
         let received = balance ourU
-        let spent = balance (u `restrictedBy` ourIns) + sum wdrls
+        let spent = balance (u `restrictedBy` ourIns) + sum ourWithdrawals
         let hasKnownInput = ourIns /= mempty
         let hasKnownOutput = ourU /= mempty
+        let hasKnownWithdrawal = ourWithdrawals /= mempty
         return $ if hasKnownOutput && not hasKnownInput then
             ( (tx, mkTxMeta received Incoming) : txs
             , u'
             )
-        else if hasKnownInput then
-            ( (tx, mkTxMeta (spent - received) Outgoing) : txs
+        else if hasKnownInput || hasKnownWithdrawal then
+            let dir = if spent > received then Outgoing else Incoming in
+            ( (tx, mkTxMeta (distance spent received) dir) : txs
             , u'
             )
         else