Yet another fix for reported withdrawals in transactions + underflow in case of key deposit reclaim

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