Merge #2560

2560: Validate output bundles when processing coin selection requests r=jonathanknowles a=jonathanknowles

# Issue Number

ADP-727
ADP-782

# Overview

This PR adds validation to coin selection requests, checking all **user-specified outputs** meet the following pre-conditions:

- output bundles do not include token quantities in excess of the maximum bound:
    `maxBound :: Word64`
- output bundles, when serialized, are within the size limit specified by the protocol:
    `4000` bytes
    
If either of the above pre-conditions are violated, an API error is returned, with a message that informs the user how they can solve the problem (usually by breaking up bundles into smaller bundles):

- `ErrOutputTokenBundleSizeExceedsLimit`
- `ErrOutputTokenQuantityExceedsLimit`

# Testing

This PR adds integration tests for both of the above scenarios:

- `WALLETS_COIN_SELECTION_07`
- `WALLETS_COIN_SELECTION_08`

# Refactoring

This PR also performs a small refactoring in the same spirit as the refactorings included in PR #2552.

We extract out `partition` functions for `Coin` and `TokenQuantity` values into the modules that define their types, similarly to the `X.equipartition` functions.

Co-authored-by: Jonathan Knowles <[email protected]>

lib/core-integration/src/Test/Integration/Framework/TestData.hs

@@ -77,12 +77,20 @@ module Test.Integration.Framework.TestData
     , errMsg403CouldntIdentifyAddrAsMine
     , errMsg503PastHorizon
     , errMsg403WrongIndex
+    , errMsg403OutputTokenBundleSizeExceedsLimit
+    , errMsg403OutputTokenQuantityExceedsLimit
     ) where
 
 import Prelude
 
 import Cardano.Wallet.Api.Types
     ( ApiAssetMetadata (ApiAssetMetadata), ApiT (..) )
+import Cardano.Wallet.Primitive.Types.Address
+    ( Address )
+import Cardano.Wallet.Primitive.Types.TokenPolicy
+    ( TokenName, TokenPolicyId )
+import Cardano.Wallet.Primitive.Types.TokenQuantity
+    ( TokenQuantity )
 import Cardano.Wallet.Unsafe
     ( unsafeFromText )
 import Cardano.Wallet.Version
@@ -91,6 +99,8 @@ import Data.Text
     ( Text, pack, unpack )
 import Data.Word
     ( Word32 )
+import Fmt
+    ( pretty )
 import Test.Integration.Framework.DSL
     ( Payload (..), fixturePassphrase, json )
 
@@ -442,3 +452,46 @@ errMsg403WrongIndex :: String
 errMsg403WrongIndex = "It looks like you've provided a derivation index that is out of bound.\
      \ The index is well-formed, but I require indexes valid for hardened derivation only. That\
      \ is, indexes between 2147483648 and 4294967295 with a suffix 'H'."
+
+errMsg403OutputTokenBundleSizeExceedsLimit
+    :: Address
+    -> Int
+    -- ^ Asset count
+    -> String
+errMsg403OutputTokenBundleSizeExceedsLimit
+    address assetCount = mconcat
+        [ "One of the outputs you've specified contains too many assets. "
+        , "Try splitting these assets across two or more outputs. "
+        , "Destination address: "
+        , pretty address
+        , ". Asset count: "
+        , pretty assetCount
+        , "."
+        ]
+
+errMsg403OutputTokenQuantityExceedsLimit
+    :: Address
+    -> TokenPolicyId
+    -> TokenName
+    -> TokenQuantity
+    -- ^ Specified token quantity
+    -> TokenQuantity
+    -- ^ Maximum allowable token quantity
+    -> String
+errMsg403OutputTokenQuantityExceedsLimit
+    address policy asset quantity quantityMaxBound = mconcat
+        [ "One of the token quantities you've specified is greater than the "
+        , "maximum quantity allowed in a single transaction output. Try "
+        , "splitting this quantity across two or more outputs. "
+        , "Destination address: "
+        , pretty address
+        , ". Token policy identifier: "
+        , pretty policy
+        , ". Asset name: "
+        , pretty asset
+        , ". Token quantity specified: "
+        , pretty quantity
+        , ". Maximum allowable token quantity: "
+        , pretty quantityMaxBound
+        , "."
+        ]

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

@@ -9,6 +9,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{- HLINT ignore "Use camelCase" -}
 
 module Test.Integration.Scenario.API.Shelley.CoinSelections
     ( spec
@@ -45,6 +46,16 @@ import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( ShelleyKey )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( coinTypeAda, purposeBIP44, purposeCIP1852 )
+import Cardano.Wallet.Primitive.Types.Hash
+    ( Hash (..) )
+import Cardano.Wallet.Primitive.Types.TokenMap
+    ( AssetId (..) )
+import Cardano.Wallet.Primitive.Types.TokenPolicy
+    ( TokenName (..), TokenPolicyId (..) )
+import Cardano.Wallet.Primitive.Types.TokenQuantity
+    ( TokenQuantity (..) )
+import Cardano.Wallet.Primitive.Types.Tx
+    ( txOutMaxTokenQuantity )
 import Control.Monad
     ( forM_ )
 import Data.Generics.Internal.VL.Lens
@@ -86,15 +97,20 @@ import Test.Integration.Framework.DSL
     )
 import Test.Integration.Framework.TestData
     ( errMsg400TxMetadataStringTooLong
+    , errMsg403OutputTokenBundleSizeExceedsLimit
+    , errMsg403OutputTokenQuantityExceedsLimit
     , errMsg404NoWallet
     , errMsg406
     , errMsg415
     )
 
 import qualified Cardano.Wallet.Api.Link as Link
+import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
+import qualified Cardano.Wallet.Primitive.Types.TokenQuantity as TokenQuantity
 import qualified Data.HashSet as Set
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import qualified Network.HTTP.Types as HTTP
 
 spec :: forall n.
@@ -293,6 +309,66 @@ spec = describe "SHELLEY_COIN_SELECTION" $ do
                     (isValidDerivationPath purposeBIP44 . view #derivationPath))
             ]
 
+    -- Attempt to create a coin selection with an output that has an
+    -- excessively high token quantity. (This should fail.)
+    it "WALLETS_COIN_SELECTION_07 - \
+        \Single output with excessively high token quantity." $
+        \ctx -> runResourceT $ do
+            let assetName = UnsafeTokenName "1"
+            let policyId = UnsafeTokenPolicyId $
+                    Hash "1234567890123456789012345678"
+            let adaQuantity = Quantity minUTxOValue
+            let assetId = AssetId policyId assetName
+            let excessiveQuantity = TokenQuantity.succ txOutMaxTokenQuantity
+            let nonAdaQuantities = TokenMap.singleton assetId excessiveQuantity
+            sourceWallet <- fixtureWallet ctx
+            targetWallet <- emptyWallet ctx
+            targetAddress : _ <- fmap (view #id) <$>
+                listAddresses @n ctx targetWallet
+            let payment = AddressAmount
+                    targetAddress adaQuantity (ApiT nonAdaQuantities)
+            let makeRequest = selectCoins
+                    @_ @'Shelley ctx sourceWallet (payment :| [])
+            makeRequest >>= flip verify
+                [ expectResponseCode HTTP.status403
+                , expectErrorMessage $ errMsg403OutputTokenQuantityExceedsLimit
+                    (getApiT $ fst targetAddress)
+                    (policyId)
+                    (assetName)
+                    (excessiveQuantity)
+                    (txOutMaxTokenQuantity)
+                ]
+
+    -- Attempt to create a coin selection with an output that has an excessive
+    -- number of assets, such that the serialized representation of the output
+    -- would exceed the limit required by the protocol. (This should fail.)
+    it "WALLETS_COIN_SELECTION_08 - \
+        \Single output with excessively high number of assets." $
+        \ctx -> runResourceT $ do
+            let adaQuantity = Quantity minUTxOValue
+            let assetCount = 1024
+            let policyId = UnsafeTokenPolicyId $
+                    Hash "1234567890123456789012345678"
+            let tokenNames = UnsafeTokenName . T.encodeUtf8 . T.singleton <$>
+                    ['a' ..]
+            let assetIds = AssetId policyId <$> take assetCount tokenNames
+            let nonAdaQuantities = TokenMap.fromFlatList $
+                    (, TokenQuantity 1) <$> assetIds
+            sourceWallet <- fixtureWallet ctx
+            targetWallet <- emptyWallet ctx
+            targetAddress : _ <- fmap (view #id) <$>
+                listAddresses @n ctx targetWallet
+            let payment = AddressAmount
+                    targetAddress adaQuantity (ApiT nonAdaQuantities)
+            let makeRequest = selectCoins
+                    @_ @'Shelley ctx sourceWallet (payment :| [])
+            makeRequest >>= flip verify
+                [ expectResponseCode HTTP.status403
+                , expectErrorMessage $ errMsg403OutputTokenBundleSizeExceedsLimit
+                    (getApiT $ fst targetAddress)
+                    (assetCount)
+                ]
+
 isValidDerivationPath
     :: Index 'Hardened 'PurposeK
     -> NonEmpty (ApiT DerivationIndex)

lib/core/src/Cardano/Wallet.hs

@@ -334,6 +334,7 @@ import Cardano.Wallet.Transaction
     ( DelegationAction (..)
     , ErrDecodeSignedTx (..)
     , ErrMkTx (..)
+    , ErrSelectionCriteria (..)
     , TransactionCtx (..)
     , TransactionLayer (..)
     , Withdrawal (..)
@@ -1400,11 +1401,13 @@ selectAssets ctx (utxo, cp, pending) tx outs transform = do
 
     pp <- liftIO $ currentProtocolParameters nl
     liftIO $ traceWith tr $ MsgSelectionStart utxo outs
+    selectionCriteria <- withExceptT ErrSelectAssetsCriteriaError $ except $
+        initSelectionCriteria tl pp tx utxo outs
     sel <- performSelection
         (calcMinimumCoinValue tl pp)
         (calcMinimumCost tl pp tx)
         (tokenBundleSizeAssessor tl)
-        (initSelectionCriteria tl pp tx utxo outs)
+        (selectionCriteria)
     liftIO $ traceWith tr $ MsgSelectionDone sel
     withExceptT ErrSelectAssetsSelectionError $ except $
         transform (getState cp) <$> sel
@@ -2168,7 +2171,8 @@ data ErrStartTimeLaterThanEndTime = ErrStartTimeLaterThanEndTime
     } deriving (Show, Eq)
 
 data ErrSelectAssets
-    = ErrSelectAssetsNoSuchWallet ErrNoSuchWallet
+    = ErrSelectAssetsCriteriaError ErrSelectionCriteria
+    | ErrSelectAssetsNoSuchWallet ErrNoSuchWallet
     | ErrSelectAssetsAlreadyWithdrawing Tx
     | ErrSelectAssetsSelectionError SelectionError
     deriving (Generic, Eq, Show)

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

@@ -354,6 +354,9 @@ import Cardano.Wallet.TokenMetadata
     ( TokenMetadataClient, fillMetadata )
 import Cardano.Wallet.Transaction
     ( DelegationAction (..)
+    , ErrOutputTokenBundleSizeExceedsLimit (..)
+    , ErrOutputTokenQuantityExceedsLimit (..)
+    , ErrSelectionCriteria (..)
     , TransactionCtx (..)
     , TransactionLayer
     , Withdrawal (..)
@@ -2866,8 +2869,45 @@ instance LiftHandler (ErrInvalidDerivationIndex 'Soft level) where
                 , "between ", pretty minIx, " and ", pretty maxIx, " without a suffix."
                 ]
 
+instance LiftHandler ErrSelectionCriteria where
+    handler = \case
+        ErrSelectionCriteriaOutputTokenBundleSizeExceedsLimit e ->
+            handler e
+        ErrSelectionCriteriaOutputTokenQuantityExceedsLimit e ->
+            handler e
+
+instance LiftHandler ErrOutputTokenBundleSizeExceedsLimit where
+    handler e = apiError err403 OutputTokenBundleSizeExceedsLimit $ mconcat
+        [ "One of the outputs you've specified contains too many assets. "
+        , "Try splitting these assets across two or more outputs. "
+        , "Destination address: "
+        , pretty (view #address e)
+        , ". Asset count: "
+        , pretty (view #assetCount e)
+        , "."
+        ]
+
+instance LiftHandler ErrOutputTokenQuantityExceedsLimit where
+    handler e = apiError err403 OutputTokenQuantityExceedsLimit $ mconcat
+        [ "One of the token quantities you've specified is greater than the "
+        , "maximum quantity allowed in a single transaction output. Try "
+        , "splitting this quantity across two or more outputs. "
+        , "Destination address: "
+        , pretty (view #address e)
+        , ". Token policy identifier: "
+        , pretty (view #tokenPolicyId $ asset e)
+        , ". Asset name: "
+        , pretty (view #tokenName $ asset e)
+        , ". Token quantity specified: "
+        , pretty (view #quantity e)
+        , ". Maximum allowable token quantity: "
+        , pretty (view #quantityMaxBound e)
+        , "."
+        ]
+
 instance LiftHandler ErrSelectAssets where
     handler = \case
+        ErrSelectAssetsCriteriaError e -> handler e
         ErrSelectAssetsNoSuchWallet e -> handler e
         ErrSelectAssetsAlreadyWithdrawing tx ->
             apiError err403 AlreadyWithdrawing $ mconcat

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

@@ -1084,6 +1084,8 @@ data ApiErrorCode
     | SoftDerivationRequired
     | HardenedDerivationRequired
     | AssetNotPresent
+    | OutputTokenBundleSizeExceedsLimit
+    | OutputTokenQuantityExceedsLimit
     deriving (Eq, Generic, Show, Data, Typeable)
     deriving anyclass NFData
 

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

@@ -85,7 +85,7 @@ import Prelude
 import Algebra.PartialOrd
     ( PartialOrd (..) )
 import Cardano.Numeric.Util
-    ( padCoalesce, partitionNatural )
+    ( padCoalesce )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..), addCoin, subtractCoin, sumCoins )
 import Cardano.Wallet.Primitive.Types.TokenBundle
@@ -143,6 +143,7 @@ import Numeric.Natural
 import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
 import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
 import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
+import qualified Cardano.Wallet.Primitive.Types.TokenQuantity as TokenQuantity
 import qualified Cardano.Wallet.Primitive.Types.Tx as Tx
 import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex
 import qualified Data.Foldable as F
@@ -842,7 +843,7 @@ tokenBundleSizeExceedsLimit (TokenBundleSizeAssessor assess) b =
     case assess b of
         TokenBundleSizeWithinLimit->
             False
-        TokenBundleSizeExceedsLimit ->
+        OutputTokenBundleSizeExceedsLimit ->
             True
 
 -- | Constructs change bundles for a set of selected inputs and outputs.
@@ -1176,20 +1177,15 @@ makeChangeForUserSpecifiedAsset
     -> (AssetId, TokenQuantity)
         -- ^ A surplus token quantity to distribute.
     -> NonEmpty TokenMap
-makeChangeForUserSpecifiedAsset targets (asset, TokenQuantity excess) =
-    let
-        partition = fromMaybe zeros (partitionNatural excess weights)
-    in
-        TokenMap.singleton asset . TokenQuantity <$> partition
+makeChangeForUserSpecifiedAsset targets (asset, excess) =
+    TokenMap.singleton asset <$>
+        fromMaybe zeros (TokenQuantity.partition excess weights)
   where
-    weights :: NonEmpty Natural
-    weights = byAsset asset <$> targets
-      where
-        byAsset :: AssetId -> TokenMap -> Natural
-        byAsset x = unTokenQuantity . flip TokenMap.getQuantity x
+    weights :: NonEmpty TokenQuantity
+    weights = flip TokenMap.getQuantity asset <$> targets
 
-    zeros :: NonEmpty Natural
-    zeros = 0 :| replicate (length targets - 1) 0
+    zeros :: NonEmpty TokenQuantity
+    zeros = TokenQuantity 0 <$ targets
 
 -- | Constructs change outputs for a non-user-specified asset: an asset that
 --   was not present in the original set of outputs.
@@ -1233,19 +1229,7 @@ makeChangeForCoin
     -> Coin
         -- ^ A surplus ada quantity to be distributed.
     -> NonEmpty Coin
-makeChangeForCoin targets excess =
-    -- The 'Natural -> Coin' conversion is safe, because 'partitionNatural'
-    -- guarantees to produce a list where every entry is less than or equal to
-    -- the target value.
-    maybe zeroWeightSum (fmap unsafeNaturalToCoin)
-        (partitionNatural (coinToNatural excess) weights)
-  where
-    zeroWeightSum :: HasCallStack => a
-    zeroWeightSum = error
-        "partitionValue: The specified weights must have a non-zero sum."
-
-    weights :: NonEmpty Natural
-    weights = coinToNatural <$> targets
+makeChangeForCoin = flip Coin.unsafePartition
 
 --------------------------------------------------------------------------------
 -- Splitting bundles