Improve balanceTx error if UTxOAssumptions are broken

lib/wallet/api/http/Cardano/Wallet/Api/Http/Server/Error.hs

@@ -568,6 +568,9 @@ instance IsServerError ErrBalanceTxInternalError where
                 , "The balance is"
                 , T.pack (show v)
                 ]
+        ErrUTxOViolatesAssumptions violation ->
+            apiError err500 UTxOAssumptionsViolated $
+                fmt $ build violation
 
 instance IsServerError ErrRemoveTx where
     toServerError = \case

lib/wallet/api/http/Cardano/Wallet/Api/Types/Error.hs

@@ -94,6 +94,7 @@ data ApiErrorInfo
     | BalanceTxInternalError
     | BalanceTxUnderestimatedFee
         ApiErrorBalanceTxUnderestimatedFee
+    | UTxOAssumptionsViolated
     | CannotCoverFee
     | CreatedInvalidTransaction
     | CreatedMultiaccountTransaction

lib/wallet/src/Cardano/Wallet/Write/Tx/Balance.hs

@@ -136,7 +136,12 @@ import Cardano.Wallet.Write.Tx
 import Cardano.Wallet.Write.Tx.TimeTranslation
     ( TimeTranslation )
 import Cardano.Wallet.Write.UTxOAssumptions
-    ( UTxOAssumptions (..), assumedInputScriptTemplate, assumedTxWitnessTag )
+    ( UTxOAssumptionViolation (..)
+    , UTxOAssumptions (..)
+    , assumedInputScriptTemplate
+    , assumedTxWitnessTag
+    , validateAddresses
+    )
 import Control.Arrow
     ( left )
 import Control.Monad
@@ -277,6 +282,7 @@ data ErrSelectAssets
 
 data ErrBalanceTxInternalError
     = ErrUnderestimatedFee W.Coin SealedTx KeyWitnessCount
+    | ErrUTxOViolatesAssumptions UTxOAssumptionViolation
     | ErrFailedBalancing Cardano.Value
     deriving (Show, Eq)
 
@@ -516,6 +522,12 @@ balanceTransactionWithSelectionStrategyAndNoZeroAdaAdjustment
         -- sensible than the max execution cost.
 
         randomSeed <- stdGenSeed
+        lift $ traceWith tr $ MsgSelectionForBalancingStart
+            (UTxOIndex.size internalUtxoAvailable)
+            (BuildableInAnyEra Cardano.cardanoEra ptx)
+
+        externalSelectedUtxo <- extractExternallySelectedUTxO ptx
+
         let
             transform
                 :: Selection
@@ -527,17 +539,14 @@ balanceTransactionWithSelectionStrategyAndNoZeroAdaAdjustment
             transform sel =
                 let (sel', s') = assignChangeAddresses genChange sel s
                     inputs = F.toList (sel' ^. #inputs)
-                in  ( inputs
+                    isPreselected (i, W.TxOut o _) =
+                        UTxOIndex.member (WalletUTxO i o) externalSelectedUtxo
+                in  ( filter (not . isPreselected) inputs
                     , sel' ^. #collateral
                     , sel' ^. #change
                     , s'
                     )
 
-        lift $ traceWith tr $ MsgSelectionForBalancingStart
-            (UTxOIndex.size internalUtxoAvailable)
-            (BuildableInAnyEra Cardano.cardanoEra ptx)
-
-        externalSelectedUtxo <- extractExternallySelectedUTxO ptx
 
         let mSel = selectAssets
                 (recentEra @era)
@@ -603,6 +612,16 @@ balanceTransactionWithSelectionStrategyAndNoZeroAdaAdjustment
         , feeUpdate = UseNewTxFee $ unsafeFromLovelace minfee0
         }
 
+    let selectedUTxOAddresses = map (W.toLedger . view #address . snd)
+            $ extraInputs <> extraCollateral'
+    case validateAddresses utxoAssumptions selectedUTxOAddresses of
+        Right ()
+            -> pure ()
+        Left violation
+            -> throwE
+                $ ErrBalanceTxInternalError
+                $ ErrUTxOViolatesAssumptions violation
+
     (balance, candidateMinFee, witCount) <- balanceAfterSettingMinFee candidateTx
     surplus <- case Cardano.selectLovelace balance of
         (Cardano.Lovelace c)

lib/wallet/src/Cardano/Wallet/Write/UTxOAssumptions.hs

@@ -14,6 +14,8 @@ module Cardano.Wallet.Write.UTxOAssumptions
 
     -- * Validation
     , validateAddress
+    , validateAddresses
+    , UTxOAssumptionViolation (..)
     )
     where
 
@@ -25,6 +27,12 @@ import Cardano.Wallet.TxWitnessTag
     ( TxWitnessTag (..) )
 import Cardano.Wallet.Write.Tx
     ( Address )
+import Control.Monad
+    ( forM_ )
+import Data.Text
+    ( Text )
+import Fmt
+    ( Buildable, build )
 
 import qualified Cardano.Address.Script as CA
 import qualified Cardano.Wallet.Primitive.Types.Address as W
@@ -56,6 +64,44 @@ assumedTxWitnessTag = \case
     AllByronKeyPaymentCredentials -> TxWitnessByronUTxO
     AllScriptPaymentCredentialsFrom {} -> TxWitnessShelleyUTxO
 
+--
+-- Validation
+--
+
+data UTxOAssumptionViolation
+    = UTxOAssumptionViolation
+        Address  -- Address violating assumptions
+        Text -- ^ Textual description of assumptions
+    deriving (Eq, Show)
+
+instance Buildable UTxOAssumptionViolation where
+    build (UTxOAssumptionViolation addr assumptions)
+        = mconcat
+            [ "UTxOAssumption "
+            , build assumptions
+            , " broken by "
+            , build $ show addr
+            ]
+
+validateAddresses
+    :: UTxOAssumptions
+    -> [Address]
+    -> Either UTxOAssumptionViolation ()
+validateAddresses assumptions = case assumptions of
+    AllKeyPaymentCredentials
+        -> validateAll "AllKeyPaymentCredentials"
+    AllByronKeyPaymentCredentials
+        -> validateAll "AllByronKeyPaymentCredentials"
+    AllScriptPaymentCredentialsFrom{}
+        -> validateAll "AllScriptPaymentCredentials"
+        -- NOTE: The script lookup could provide bigger scripts than predicted
+        -- by the template. This is not currently validated.
+  where
+    validateAll assumptionText addrs = forM_ addrs $ \addr ->
+        if validateAddress assumptions addr
+        then Right ()
+        else Left $ UTxOAssumptionViolation addr assumptionText
+
 validateAddress :: UTxOAssumptions -> Address -> Bool
 validateAddress = valid
   where

lib/wallet/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs

@@ -49,14 +49,14 @@ import Cardano.Api
     , InAnyCardanoEra (..)
     , IsCardanoEra (..)
     , IsShelleyBasedEra (..)
+    , PaymentCredential (PaymentCredentialByKey)
     , ShelleyBasedEra (..)
     )
 import Cardano.Api.Gen
     ( genAddressByron
     , genAddressInEra
     , genEncodingBoundaryLovelace
     , genNetworkId
-    , genPaymentCredential
     , genSignedValue
     , genStakeAddressReference
     , genTx
@@ -67,6 +67,7 @@ import Cardano.Api.Gen
     , genTxOutDatum
     , genTxOutValue
     , genValueForTxOut
+    , genVerificationKeyHash
     , genWitnesses
     )
 import Cardano.Binary
@@ -488,6 +489,8 @@ import qualified Cardano.Wallet.Primitive.Types.Tx.TxOut.Gen as TxOutGen
 import qualified Cardano.Wallet.Shelley.Compatibility as Compatibility
 import qualified Cardano.Wallet.Write.ProtocolParameters as Write
 import qualified Cardano.Wallet.Write.Tx as Write
+import Cardano.Wallet.Write.UTxOAssumptions
+    ( UTxOAssumptionViolation (UTxOAssumptionViolation) )
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Codec.CBOR.Write as CBOR
 import qualified Data.ByteArray as BA
@@ -2238,6 +2241,12 @@ instance Show AnyChangeAddressGenWithState where
     show (AnyChangeAddressGenWithState (ChangeAddressGen gen _) s) =
             show $ toLedger $ fst $ gen s
 
+instance Arbitrary AnyChangeAddressGenWithState where
+    arbitrary = elements
+        [ dummyByronChangeAddressGen
+        , dummyShelleyChangeAddressGen
+        ]
+
 balanceTransactionSpec :: Spec
 balanceTransactionSpec = describe "balanceTransaction" $ do
     -- TODO: Create a test to show that datums are passed through...
@@ -2506,6 +2515,39 @@ balanceTransactionSpec = describe "balanceTransaction" $ do
                 `shouldBe`
                 Left (ErrBalanceTxAssignRedeemers
                         (ErrAssignRedeemersTargetNotFound faultyRedeemer))
+
+    describe "when selected UTxOs violate the UTxOAssumptions" $ do
+        it "fails with ErrBalanceTxInternalError" $ property $ \changeAddrGen seed -> do
+
+            let partialTx :: PartialTx Cardano.BabbageEra
+                partialTx = paymentPartialTx
+                        [ TxOut dummyAddr
+                            (TokenBundle.fromCoin (Coin 1_000_000))
+                        ]
+
+            let illconfiguredWallet =
+                    Wallet'
+                    AllKeyPaymentCredentials
+                    (byronUtxo (replicate 3 (Coin 1_000_000)))
+                    changeAddrGen
+
+
+            let res =
+                    balanceTx
+                        illconfiguredWallet
+                        mockPParamsForBalancing
+                        (dummyTimeTranslationWithHorizon horizon)
+                        seed
+                        partialTx
+
+            res === Left
+                ( ErrBalanceTxInternalError
+                ( ErrUTxOViolatesAssumptions
+                ( UTxOAssumptionViolation
+                    (toLedger dummyBootstrapAddr)
+                    "AllKeyPaymentCredentials")))
+
+
   where
     mapFirst f (x:xs) = f x : xs
     mapFirst _ [] = error "mapFirst: empty list"
@@ -2515,6 +2557,7 @@ balanceTransactionSpec = describe "balanceTransaction" $ do
 
     wallet = mkTestWallet (utxo [Coin 5_000_000])
 
+
     -- Wallet with only small utxos, and enough of them to fill a tx in the
     -- tests below.
     dustWallet = mkTestWallet dustUTxO
@@ -2537,6 +2580,17 @@ balanceTransactionSpec = describe "balanceTransaction" $ do
         outs = map (TxOut dummyAddr . TokenBundle.fromCoin) coins
         dummyHash = Hash $ B8.replicate 32 '0'
 
+    dummyBootstrapAddr = case dummyByronChangeAddressGen of
+        AnyChangeAddressGenWithState g s0 ->
+            fst $ getChangeAddressGen g s0
+
+    byronUtxo coins = UTxO $ Map.fromList $ zip ins outs
+      where
+        ins = map (TxIn dummyHash) [0..]
+        outs = map (TxOut dummyBootstrapAddr . TokenBundle.fromCoin) coins
+        dummyHash = Hash $ B8.replicate 32 '0'
+
+
     dummyAddr = Address $ unsafeFromHex
         "60b1e5e0fb74c86c801f646841e07cdb42df8b82ef3ce4e57cb5412e77"
 
@@ -3022,8 +3076,12 @@ instance Buildable Wallet' where
         nameF "Wallet" $ mconcat
             [ nameF "assumptions" $ build assumptions
             , nameF "changeAddressGen" $ build changeAddressGen
-            , nameF "utxo" $ pretty utxo
+            , nameF "utxo" $ build $ show $ fromWalletUTxO utxo
             ]
+          where
+            fromWalletUTxO (UTxO m) =
+                Map.mapKeys toLedger
+                $ Map.map toBabbageTxOut m
 
 instance Arbitrary Wallet' where
     arbitrary = oneof
@@ -3041,7 +3099,8 @@ instance Arbitrary Wallet' where
         genShelleyVkAddr = Cardano.shelleyAddressInEra
             <$> (Cardano.makeShelleyAddress
                 <$> genNetworkId
-                <*> genPaymentCredential -- only vk credentials
+                <*> (PaymentCredentialByKey
+                        <$> genVerificationKeyHash Cardano.AsPaymentKey)
                 <*> genStakeAddressReference)
 
         genByronVkAddr :: Gen (Cardano.AddressInEra Cardano.BabbageEra)