WIP: more tests

src/Contract/Transaction.purs

@@ -51,8 +51,6 @@ import Contract.TxConstraints (TxConstraints)
 import Control.Monad.Error.Class (catchError, liftEither, throwError)
 import Control.Monad.Reader (ReaderT, asks, runReaderT)
 import Control.Monad.Reader.Class (ask)
-import Ctl.Internal.BalanceTx (FinalizedTransaction)
-import Ctl.Internal.BalanceTx (FinalizedTransaction(FinalizedTransaction)) as FinalizedTransaction
 import Ctl.Internal.BalanceTx (balanceTxWithConstraints) as BalanceTx
 import Ctl.Internal.BalanceTx.Constraints (BalanceTxConstraintsBuilder)
 import Ctl.Internal.BalanceTx.Error
@@ -62,6 +60,7 @@ import Ctl.Internal.BalanceTx.Error
       , CouldNotConvertScriptOutputToTxInput
       , CouldNotGetChangeAddress
       , CouldNotGetCollateral
+      , InsufficientCollateralUtxos
       , CouldNotGetUtxos
       , CollateralReturnError
       , CollateralReturnMinAdaValueCalcError
@@ -75,6 +74,8 @@ import Ctl.Internal.BalanceTx.Error
   , ImpossibleError(Impossible)
   , InvalidInContext(InvalidInContext)
   ) as BalanceTxError
+import Ctl.Internal.BalanceTx.Types (FinalizedTransaction)
+import Ctl.Internal.BalanceTx.Types (FinalizedTransaction(FinalizedTransaction)) as FinalizedTransaction
 import Ctl.Internal.BalanceTx.UnattachedTx (UnindexedTx)
 import Ctl.Internal.Cardano.Types.NativeScript
   ( NativeScript

src/Internal/BalanceTx/BalanceTx.purs

@@ -1,7 +1,5 @@
 module Ctl.Internal.BalanceTx
-  ( module BalanceTxErrorExport
-  , module FinalizedTransaction
-  , balanceTxWithConstraints
+  ( balanceTxWithConstraints
   ) where
 
 import Prelude
@@ -39,29 +37,16 @@ import Ctl.Internal.BalanceTx.Constraints
   , _srcAddresses
   ) as Constraints
 import Ctl.Internal.BalanceTx.Error
-  ( Actual(Actual)
-  , BalanceTxError
-      ( CouldNotGetChangeAddress
+  ( BalanceTxError
+      ( BalanceInsufficientError
+      , CouldNotGetChangeAddress
       , CouldNotGetCollateral
       , CouldNotGetUtxos
-      , ExUnitsEvaluationFailed
+      , InsufficientCollateralUtxos
       , ReindexRedeemersError
       , UtxoLookupFailedFor
       , UtxoMinAdaValueCalculationFailed
       )
-  , Expected(Expected)
-  , printTxEvaluationFailure
-  ) as BalanceTxErrorExport
-import Ctl.Internal.BalanceTx.Error
-  ( BalanceTxError
-      ( UtxoLookupFailedFor
-      , UtxoMinAdaValueCalculationFailed
-      , ReindexRedeemersError
-      , BalanceInsufficientError
-      , CouldNotGetUtxos
-      , CouldNotGetCollateral
-      , CouldNotGetChangeAddress
-      )
   , InvalidInContext(InvalidInContext)
   )
 import Ctl.Internal.BalanceTx.ExUnitsAndMinFee
@@ -85,7 +70,6 @@ import Ctl.Internal.BalanceTx.Types
   , liftEitherContract
   , withBalanceTxConstraints
   )
-import Ctl.Internal.BalanceTx.Types (FinalizedTransaction(FinalizedTransaction)) as FinalizedTransaction
 import Ctl.Internal.BalanceTx.UnattachedTx
   ( EvaluatedTx
   , UnindexedTx
@@ -302,8 +286,9 @@ setTransactionCollateral changeAddr transaction = do
         maxCollateralInputs = UInt.toInt $ params.maxCollateralInputs
         utxoMap' = fromPlutusUtxoMap networkId $ Map.filterKeys isSpendable
           utxoMap
-      liftEffect $ Array.fromFoldable <<< fold <$>
+      mbCollateral <- liftEffect $ map Array.fromFoldable <$>
         selectCollateral coinsPerUtxoUnit maxCollateralInputs utxoMap'
+      liftEither $ note InsufficientCollateralUtxos mbCollateral
   addTxCollateralReturn collateral (addTxCollateral collateral transaction)
     changeAddr
 

src/Internal/BalanceTx/Error.purs

@@ -9,6 +9,7 @@ module Ctl.Internal.BalanceTx.Error
       , CouldNotConvertScriptOutputToTxInput
       , CouldNotGetChangeAddress
       , CouldNotGetCollateral
+      , InsufficientCollateralUtxos
       , CouldNotGetUtxos
       , CollateralReturnError
       , CollateralReturnMinAdaValueCalcError
@@ -73,6 +74,7 @@ data BalanceTxError
   | CouldNotConvertScriptOutputToTxInput
   | CouldNotGetChangeAddress
   | CouldNotGetCollateral
+  | InsufficientCollateralUtxos
   | CouldNotGetUtxos
   | CollateralReturnError String
   | CollateralReturnMinAdaValueCalcError

src/Internal/BalanceTx/Types.purs

@@ -22,16 +22,15 @@ import Ctl.Internal.BalanceTx.Constraints
   ( BalanceTxConstraints
   , BalanceTxConstraintsBuilder
   )
-import Ctl.Internal.BalanceTx.Constraints
-  ( buildBalanceTxConstraints
-  ) as Constraints
+import Ctl.Internal.BalanceTx.Constraints (buildBalanceTxConstraints) as Constraints
 import Ctl.Internal.BalanceTx.Error (BalanceTxError)
 import Ctl.Internal.Cardano.Types.Transaction (Costmdls(Costmdls), Transaction)
 import Ctl.Internal.Contract.Monad (Contract, ContractEnv)
 import Ctl.Internal.Serialization.Address (NetworkId)
 import Ctl.Internal.Types.ProtocolParameters (CoinsPerUtxoUnit)
 import Ctl.Internal.Types.Scripts (Language)
-import Ctl.Internal.Wallet (Cip30Wallet, cip30Wallet)
+import Ctl.Internal.Wallet (cip30Wallet)
+import Ctl.Internal.Wallet.Cip30 (Cip30Wallet)
 import Data.Either (Either)
 import Data.Generic.Rep (class Generic)
 import Data.Lens (Lens')

src/Internal/Test/KeyDir.purs

@@ -73,7 +73,7 @@ import Ctl.Internal.Types.TxConstraints
   , mustSpendPubKeyOutput
   , singleton
   )
-import Ctl.Internal.Wallet (KeyWallet)
+import Ctl.Internal.Wallet.Key (KeyWallet)
 import Data.Array (catMaybes)
 import Data.Array as Array
 import Data.BigInt (BigInt)

src/Internal/Wallet.purs

@@ -1,7 +1,5 @@
 module Ctl.Internal.Wallet
-  ( module KeyWallet
-  , module Cip30Wallet
-  , Wallet(Gero, Nami, Flint, Lode, Eternl, NuFi, Lace, KeyWallet)
+  ( Wallet(Gero, Nami, Flint, Lode, Eternl, NuFi, Lace, KeyWallet)
   , WalletExtension
       ( NamiWallet
       , LodeWallet
@@ -49,7 +47,6 @@ import Ctl.Internal.Cardano.Types.Transaction
   )
 import Ctl.Internal.Helpers ((<<>>))
 import Ctl.Internal.Types.Natural (fromInt', minus)
-import Ctl.Internal.Wallet.Cip30 (Cip30Connection, Cip30Wallet) as Cip30Wallet
 import Ctl.Internal.Wallet.Cip30
   ( Cip30Connection
   , Cip30Wallet
@@ -61,7 +58,6 @@ import Ctl.Internal.Wallet.Key
   , PrivateStakeKey
   , privateKeysToKeyWallet
   )
-import Ctl.Internal.Wallet.Key (KeyWallet, privateKeysToKeyWallet) as KeyWallet
 import Data.Int (toNumber)
 import Data.Maybe (Maybe(Just, Nothing), fromJust)
 import Data.Newtype (over, wrap)

test/Ogmios/Aeson.purs

@@ -11,7 +11,7 @@ import Aeson as Aeson
 import Control.Monad.Error.Class (liftEither)
 import Control.Monad.Trans.Class (lift)
 import Control.Parallel (parTraverse)
-import Ctl.Internal.BalanceTx (printTxEvaluationFailure)
+import Ctl.Internal.BalanceTx.Error (printTxEvaluationFailure)
 import Ctl.Internal.QueryM.Ogmios as O
 import Ctl.Internal.Test.TestPlanM (TestPlanM, interpret)
 import Data.Array (catMaybes, elem, filter, groupAllBy, nubBy)

test/Plutip/Contract.purs

@@ -18,6 +18,7 @@ import Contract.BalanceTxConstraints
   ) as BalanceTxConstraints
 import Contract.BalanceTxConstraints
   ( mustNotSpendUtxosWithOutRefs
+  , mustUseCollateralUtxos
   )
 import Contract.Chain (currentTime, waitUntilSlot)
 import Contract.Hashing (datumHash, nativeScriptHash)
@@ -63,7 +64,7 @@ import Contract.Test.Plutip
   )
 import Contract.Time (Slot(Slot), getEraSummaries)
 import Contract.Transaction
-  ( BalanceTxError(BalanceInsufficientError)
+  ( BalanceTxError(BalanceInsufficientError, InsufficientCollateralUtxos)
   , DataHash
   , InvalidInContext(InvalidInContext)
   , NativeScript(ScriptPubkey, ScriptNOfK, ScriptAll)
@@ -170,8 +171,9 @@ import Data.Tuple (Tuple(Tuple))
 import Data.Tuple.Nested (type (/\), (/\))
 import Data.UInt (UInt)
 import Effect.Class (liftEffect)
+import Effect.Console as Console
 import Effect.Exception (throw)
-import Mote (group, skip, test)
+import Mote (group, only, skip, test)
 import Partial.Unsafe (unsafePartial)
 import Safe.Coerce (coerce)
 import Test.Ctl.Fixtures
@@ -270,7 +272,70 @@ suite = do
 
       withWallets distribution \_ → pure unit
 
-  group "Contract interface" do
+  only $ group "Contract interface" do
+    only $ test
+      "mustUseCollateralUtxos should not fail if enough UTxOs are provided"
+      do
+        let
+          someUtxos =
+            [ BigInt.fromInt 5_000_000
+            , BigInt.fromInt 5_000_000
+            ]
+        withWallets (someUtxos /\ someUtxos) \(alice /\ bob) -> do
+          bobsCollateral <- withKeyWallet bob do
+            fromMaybe Map.empty <$> getWalletUtxos
+          withKeyWallet alice do
+            pkh <- liftedM "Failed to get PKH" $ head <$> withKeyWallet alice
+              ownPaymentPubKeyHashes
+            stakePkh <- join <<< head <$> withKeyWallet alice
+              ownStakePubKeyHashes
+            let
+              constraints :: Constraints.TxConstraints Void Void
+              constraints = mustPayToPubKeyStakeAddress pkh stakePkh
+                $ Value.lovelaceValueOf
+                $ BigInt.fromInt 2_000_000
+
+              lookups :: Lookups.ScriptLookups Void
+              lookups = mempty
+            ubTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints
+            res <-
+              ( balanceTxWithConstraints ubTx
+                  $ mustUseCollateralUtxos bobsCollateral
+              )
+            res `shouldSatisfy` isRight
+
+    only $ test
+      "mustUseCollateralUtxos should fail if not enough UTxOs are provided"
+      do
+        let
+          someUtxos =
+            [ BigInt.fromInt 5_000_000
+            , BigInt.fromInt 5_000_000
+            ]
+        withWallets someUtxos \alice -> do
+          withKeyWallet alice do
+            pkh <- liftedM "Failed to get PKH" $ head <$> withKeyWallet alice
+              ownPaymentPubKeyHashes
+            stakePkh <- join <<< head <$> withKeyWallet alice
+              ownStakePubKeyHashes
+            let
+              constraints :: Constraints.TxConstraints Void Void
+              constraints = mustPayToPubKeyStakeAddress pkh stakePkh
+                $ Value.lovelaceValueOf
+                $ BigInt.fromInt 2_000_000
+
+              lookups :: Lookups.ScriptLookups Void
+              lookups = mempty
+            ubTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints
+            res <-
+              ( balanceTxWithConstraints ubTx
+                  $ mustUseCollateralUtxos Map.empty
+              )
+            liftEffect $ Console.log $ show $ res
+            res `shouldSatisfy` case _ of
+              Left InsufficientCollateralUtxos -> true
+              _ -> false
+
     test "Collateral selection: UTxO with lower amount is selected" do
       let
         distribution :: InitialUTxOs /\ InitialUTxOs