Merge #2542

2542: Fix calculation of missing balance in API error r=Anviking a=Anviking

# Issue Number

ADP-697

# Overview

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

- [x] Add new `difference` function for `TokenMap` and `TokenBundle`
- [x] Calculate the missing balance using `required - available` using `difference` rather than `subtract` 
- [x] TODO: More tests?
- [ ] TODO: Can we property test the API handler?
    - Since this logic is in the API rendering of the errors, it seems very tricky.


# Comments

Analysis of problem:

In Server.hs there's this calculation:

```
                        missing
                            = TokenBundle.Flat
                            $ fromMaybe TokenBundle.empty
                            $ TokenBundle.subtract
                                balanceRequired balanceAvailable
```

But because of this requirement of TokenBundle.subtract
```haskell
-- Returns 'Nothing' if the second bundle is not less than or equal to the first
-- bundle when compared with the `leq` function.
```
it should mean that if we own tokens that are not required, then we hit the nothing case, and we get a missing `coin: 0 tokens: []`.

Think we need something like this:
```haskell
difference :: TokenMap -> TokenMap -> TokenMap
difference = modifySimple $ Map.differenceWith TokenQuantity.subtract
  where
    modifySimple
        :: (Map AssetId TokenQuantity -> Map AssetId TokenQuantity -> Map AssetId TokenQuantity)
        -> TokenMap
        -> TokenMap
        -> TokenMap
    modifySimple f x y = fromFlatList . Map.toList
        $ f (Map.fromList . toFlatList $ x)
            (Map.fromList . toFlatList $ y)
```

<!-- 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)
 ✓ Jira will detect and link to this PR once created, but you can also link this PR in the description of the corresponding ticket
 ✓ Acknowledge any changes required to the Wiki
 ✓ Finally, in the PR description delete any empty sections and all text commented in <!--, so that this text does not appear in merge commit messages.
-->


Co-authored-by: Johannes Lund <johannes.lund@iohk.io>
Co-authored-by: Jonathan Knowles <jonathan.knowles@iohk.io>

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

@@ -281,10 +281,10 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     , purposeCIP1852
     )
 import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
-    ( BalanceInsufficientError (..)
-    , SelectionError (..)
+    ( SelectionError (..)
     , SelectionInsufficientError (..)
     , UnableToConstructChangeError (..)
+    , balanceMissing
     , selectionDelta
     )
 import Cardano.Wallet.Primitive.Model
@@ -328,7 +328,7 @@ import Cardano.Wallet.Primitive.Types.Coin
 import Cardano.Wallet.Primitive.Types.Hash
     ( Hash (..) )
 import Cardano.Wallet.Primitive.Types.TokenBundle
-    ( TokenBundle (..) )
+    ( Flat (..), TokenBundle (..) )
 import Cardano.Wallet.Primitive.Types.TokenMap
     ( AssetId (..) )
 import Cardano.Wallet.Primitive.Types.TokenPolicy
@@ -2873,23 +2873,11 @@ instance LiftHandler ErrSelectAssets where
         ErrSelectAssetsSelectionError selectionError ->
             case selectionError of
                 BalanceInsufficient e ->
-                    let
-                        BalanceInsufficientError
-                            { balanceRequired
-                            , balanceAvailable
-                            } = e
-
-                        missing
-                            = TokenBundle.Flat
-                            $ fromMaybe TokenBundle.empty
-                            $ TokenBundle.subtract
-                                balanceRequired balanceAvailable
-                    in
-                        apiError err403 NotEnoughMoney $ mconcat
-                            [ "I can't process this payment as there are not "
-                            , "enough funds available in the wallet. I am only "
-                            , "missing: ", pretty missing
-                            ]
+                    apiError err403 NotEnoughMoney $ mconcat
+                        [ "I can't process this payment as there are not "
+                        , "enough funds available in the wallet. I am "
+                        , "missing: ", pretty . Flat $ balanceMissing e
+                        ]
                 SelectionInsufficient e ->
                     apiError err403 TransactionIsTooBig $ mconcat
                         [ "I am not able to finalize the transaction "

lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs

@@ -81,6 +81,7 @@ module Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
     -- * Utility functions
     , distance
     , mapMaybe
+    , balanceMissing
     ) where
 
 import Prelude
@@ -321,6 +322,11 @@ data BalanceInsufficientError = BalanceInsufficientError
       -- ^ The balance of 'outputsToCover'.
     } deriving (Generic, Eq, Show)
 
+-- | Calculate the missing balance from a @BalanceInsufficientError@.
+balanceMissing :: BalanceInsufficientError -> TokenBundle
+balanceMissing (BalanceInsufficientError available required) =
+    TokenBundle.difference required available
+
 -- | Indicates that a particular output does not have the minimum coin quantity
 --   expected by the protocol.
 --

lib/core/src/Cardano/Wallet/Primitive/Types/TokenBundle.hs

@@ -44,6 +44,7 @@ module Cardano.Wallet.Primitive.Types.TokenBundle
     -- * Arithmetic
     , add
     , subtract
+    , difference
 
     -- * Quantities
     , getQuantity
@@ -96,6 +97,8 @@ import Data.Map.Strict
     ( Map )
 import Data.Map.Strict.NonEmptyMap
     ( NonEmptyMap )
+import Data.Maybe
+    ( fromMaybe )
 import Data.Set
     ( Set )
 import Fmt
@@ -105,6 +108,7 @@ import GHC.Generics
 import GHC.TypeLits
     ( ErrorMessage (..), TypeError )
 
+import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
 import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
 
 --------------------------------------------------------------------------------
@@ -293,6 +297,28 @@ add (TokenBundle (Coin c1) m1) (TokenBundle (Coin c2) m2) =
 subtract :: TokenBundle -> TokenBundle -> Maybe TokenBundle
 subtract a b = guard (b `leq` a) $> unsafeSubtract a b
 
+-- | Analogous to @Set.difference@, return the difference between two token
+-- maps.
+--
+-- The following property holds:
+-- prop> x `leq` (x `difference` y) `add` y
+--
+-- Note that there's a `leq` rather than equality, which we'd expect if this was
+-- subtraction of integers. I.e.
+--
+-- >>> (0 - 1) + 1
+-- 0
+--
+-- whereas
+--
+-- >>> let oneToken = fromFlatList coin [(aid, TokenQuantity 1)]
+-- >>> (mempty `difference` oneToken) `add` oneToken
+-- oneToken
+difference :: TokenBundle -> TokenBundle -> TokenBundle
+difference (TokenBundle c1 m1) (TokenBundle c2 m2) =
+    TokenBundle
+        (fromMaybe (Coin 0) $ Coin.subtractCoin c1 c2)
+        (TokenMap.difference m1 m2)
 --------------------------------------------------------------------------------
 -- Quantities
 --------------------------------------------------------------------------------

lib/core/src/Cardano/Wallet/Primitive/Types/TokenMap.hs

@@ -57,6 +57,7 @@ module Cardano.Wallet.Primitive.Types.TokenMap
     -- * Arithmetic
     , add
     , subtract
+    , difference
 
     -- * Tests
     , isEmpty
@@ -512,6 +513,30 @@ add a b = F.foldl' acc a $ toFlatList b
 subtract :: TokenMap -> TokenMap -> Maybe TokenMap
 subtract a b = guard (b `leq` a) $> unsafeSubtract a b
 
+-- | Analogous to @Set.difference@, return the difference between two token
+-- maps.
+--
+-- The following property holds:
+-- prop> x `leq` (x `difference` y) `add` y
+--
+-- Note that there's a `leq` rather than equality, which we'd expect if this was
+-- subtraction of integers. I.e.
+--
+-- >>> (0 - 1) + 1
+-- 0
+--
+-- whereas
+--
+-- >>> let oneToken = singleton aid (TokenQuantity 1)
+-- >>> (mempty `difference` oneToken) `add` oneToken
+-- oneToken
+difference :: TokenMap -> TokenMap -> TokenMap
+difference m1 m2 = L.foldl' reduce m1 (toFlatList m2)
+  where
+    reduce :: TokenMap -> (AssetId, TokenQuantity) -> TokenMap
+    reduce m (a, q) = adjustQuantity m a
+        (fromMaybe TokenQuantity.zero . (`TokenQuantity.subtract` q))
+
 --------------------------------------------------------------------------------
 -- Tests
 --------------------------------------------------------------------------------

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobinSpec.hs

@@ -34,6 +34,7 @@ import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
     , UnableToConstructChangeError (..)
     , assetSelectionLens
     , assignCoinsToChangeMaps
+    , balanceMissing
     , coinSelectionLens
     , equipartitionNatural
     , equipartitionTokenBundleWithMaxQuantity
@@ -585,6 +586,12 @@ prop_performSelection_small minCoinValueFor costFor (Blind (Small criteria)) =
         "balance sufficient" $
     cover 30 (not $ balanceSufficient criteria)
         "balance insufficient" $
+    cover 5 (utxoHasAtLeastOneAsset)
+        "No assets in UTxO" $
+    cover 5 (not outputsHaveAtLeastOneAsset)
+        "No assets to cover" $
+    cover 2 (outputsHaveAtLeastOneAsset && not utxoHasAtLeastOneAsset)
+        "Assets to cover, but no assets in UTxO" $
     prop_performSelection minCoinValueFor costFor (Blind criteria) $ \result ->
         cover 10 (selectionUnlimited && selectionSufficient result)
             "selection unlimited and sufficient"
@@ -593,6 +600,19 @@ prop_performSelection_small minCoinValueFor costFor (Blind (Small criteria)) =
         . cover 10 (selectionLimited && selectionInsufficient result)
             "selection limited and insufficient"
   where
+    utxoHasAtLeastOneAsset = not
+        . Set.null
+        . UTxOIndex.assets
+        $ utxoAvailable criteria
+
+    outputsHaveAtLeastOneAsset =
+        not . Set.null $ TokenBundle.getAssets outputTokens
+      where
+        outputTokens = mconcat
+            . F.toList
+            . fmap (view #tokens)
+            $ outputsToCover criteria
+
     selectionLimited :: Bool
     selectionLimited = case selectionLimit criteria of
         MaximumInputLimit _ -> True
@@ -733,15 +753,21 @@ prop_performSelection minCoinValueFor costFor (Blind criteria) coverage =
             onUnableToConstructChange e
 
     onBalanceInsufficient e = do
+        let balanceAvailable' = TokenBundle.add (balanceMissing e) balanceAvailable
         monitor $ counterexample $ unlines
             [ "available balance:"
             , pretty (Flat balanceAvailable)
             , "required balance:"
             , pretty (Flat balanceRequired)
+            , "missing balance:"
+            , pretty (Flat $ balanceMissing e)
+            , "missing + available balance:"
+            , pretty (Flat balanceAvailable')
             ]
         assert $ not $ balanceSufficient criteria
         assert $ balanceAvailable == errorBalanceAvailable
         assert $ balanceRequired  == errorBalanceRequired
+        assert (balanceRequired `leq` balanceAvailable')
       where
         BalanceInsufficientError errorBalanceAvailable errorBalanceRequired = e
 

lib/core/test/unit/Cardano/Wallet/Primitive/Types/TokenBundleSpec.hs

@@ -6,18 +6,29 @@ module Cardano.Wallet.Primitive.Types.TokenBundleSpec
     ( spec
     ) where
 
-import Prelude
+import Prelude hiding
+    ( subtract )
 
+import Algebra.PartialOrd
+    ( leq )
 import Cardano.Wallet.Primitive.Types.TokenBundle
-    ( TokenBundle )
+    ( TokenBundle, add, difference, isCoin, subtract, unsafeSubtract )
 import Cardano.Wallet.Primitive.Types.TokenBundle.Gen
     ( genTokenBundleSmallRange, shrinkTokenBundleSmallRange )
 import Test.Hspec
-    ( Spec, describe )
+    ( Spec, describe, it )
 import Test.Hspec.Core.QuickCheck
     ( modifyMaxSuccess )
 import Test.QuickCheck
-    ( Arbitrary (..) )
+    ( Arbitrary (..)
+    , Property
+    , checkCoverage
+    , counterexample
+    , cover
+    , property
+    , (===)
+    , (==>)
+    )
 import Test.QuickCheck.Classes
     ( eqLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws )
 import Test.Utils.Laws
@@ -39,6 +50,71 @@ spec =
             , semigroupMonoidLaws
             ]
 
+    describe "Arithmetic" $ do
+        it "prop_difference_zero (x - 0 = x)" $
+            property prop_difference_zero
+        it "prop_difference_zero2 (0 - x = 0)" $
+            property prop_difference_zero2
+        it "prop_difference_zero3 (x - x = 0)" $
+            property prop_difference_zero3
+        it "prop_difference_leq (x - y ⊆ x)" $
+            property prop_difference_leq
+        it "prop_difference_add ((x - y) + y ⊇ x)" $
+            property prop_difference_add
+        it "prop_difference_subtract" $
+            property prop_difference_subtract
+        it "prop_difference_equality" $
+            property prop_difference_equality
+
+--------------------------------------------------------------------------------
+-- Arithmetic properties
+--------------------------------------------------------------------------------
+
+prop_difference_zero :: TokenBundle -> Property
+prop_difference_zero x =
+    x `difference` mempty === x
+
+prop_difference_zero2 :: TokenBundle -> Property
+prop_difference_zero2 x =
+    mempty `difference` x === mempty
+
+prop_difference_zero3 :: TokenBundle -> Property
+prop_difference_zero3 x =
+    x `difference` x === mempty
+
+prop_difference_leq :: TokenBundle -> TokenBundle -> Property
+prop_difference_leq x y = do
+    let delta = x `difference` y
+    counterexample ("x - y = " <> show delta) $ property $ delta `leq` x
+
+-- (x - y) + y ⊇ x
+prop_difference_add :: TokenBundle -> TokenBundle -> Property
+prop_difference_add x y =
+    let
+        delta = x `difference` y
+        yAndDelta = delta `add` y
+    in
+        counterexample ("x - y = " <> show delta) $
+        counterexample ("(x - y) + y = " <> show yAndDelta) $
+        property $ x `leq` yAndDelta
+
+prop_difference_subtract :: TokenBundle -> TokenBundle -> Property
+prop_difference_subtract x y =
+    y `leq` x ==> (===)
+        (x `subtract` y)
+        (Just $ x `difference` y)
+
+prop_difference_equality :: TokenBundle -> TokenBundle -> Property
+prop_difference_equality x y = checkCoverage $
+    cover 5 (not (isCoin xReduced))
+        "reduced bundles are not coins" $
+    xReduced === yReduced
+  where
+    xReduced = x `unsafeSubtract` xExcess
+    yReduced = y `unsafeSubtract` yExcess
+    xExcess = x `difference` y
+    yExcess = y `difference` x
+
 --------------------------------------------------------------------------------
 -- Arbitrary instances
 --------------------------------------------------------------------------------