Restore onClusterStartup hook for cardano-testnet

packages.dhall

@@ -3,4 +3,51 @@ let upstream =
       https://raw.githubusercontent.com/mlabs-haskell/purescript-cardano-package-set/v3.0.0/packages.dhall
         sha256:53f8de47606b6cb349432c2f2f03e656b204ebe132ef2d39d76339d9d97620ee
 
-in upstream
+let additions =
+      { cardano-transaction-balancer =
+        { dependencies =
+          [ "aff"
+          , "ansi"
+          , "arrays"
+          , "bifunctors"
+          , "bytearrays"
+          , "cardano-data-lite"
+          , "cardano-provider"
+          , "cardano-transaction-builder"
+          , "cardano-types"
+          , "console"
+          , "effect"
+          , "either"
+          , "exceptions"
+          , "foldable-traversable"
+          , "integers"
+          , "js-bigints"
+          , "js-date"
+          , "lattice"
+          , "lists"
+          , "literals"
+          , "maybe"
+          , "monad-logger"
+          , "newtype"
+          , "ordered-collections"
+          , "parallel"
+          , "partial"
+          , "prelude"
+          , "profunctor"
+          , "profunctor-lenses"
+          , "quickcheck"
+          , "random"
+          , "strings"
+          , "stringutils"
+          , "these"
+          , "transformers"
+          , "tuples"
+          , "uint"
+          , "unsafe-coerce"
+          ]
+        , repo = "https://github.com/mlabs-haskell/purescript-cardano-transaction-balancer"
+        , version = "a7a8a414a6235a574f092a0c7811518287c41f1b"
+        }
+      }
+
+in (upstream // additions)

src/Contract/BalanceTxConstraints.purs

@@ -6,8 +6,10 @@ import Cardano.Transaction.Balancer.Constraints
   ( BalanceTxConstraintsBuilder
   , BalancerConfig(BalancerConfig)
   , BalancerConstraints(BalancerConstraints)
+  , UtxoPredicate
   , mustGenChangeOutsWithMaxTokenQuantity
   , mustNotSpendUtxoWithOutRef
+  , mustNotSpendUtxosWhere
   , mustNotSpendUtxosWithOutRefs
   , mustSendChangeToAddress
   , mustSendChangeWithDatum

src/Internal/Contract/Hooks.purs

@@ -6,11 +6,11 @@ module Ctl.Internal.Contract.Hooks
 
 import Prelude
 
-import Cardano.Types.PrivateKey (PrivateKey)
 import Cardano.Types.Transaction (Transaction)
 import Data.Maybe (Maybe(Nothing))
 import Effect (Effect)
 import Effect.Exception (Error)
+import Node.Path (FilePath)
 
 type Hooks =
   { beforeSign :: Maybe (Effect Unit)
@@ -22,10 +22,8 @@ type Hooks =
   }
 
 type ClusterParameters =
-  { privateKeys :: Array PrivateKey
-  , nodeSocketPath :: String
-  , nodeConfigPath :: String
-  , privateKeysDirectory :: String
+  { nodeSocketPath :: FilePath
+  , nodeConfigPath :: FilePath
   }
 
 emptyHooks :: Hooks

src/Internal/Testnet/Contract.purs

@@ -44,6 +44,7 @@ import Control.Monad.State (State, execState, modify_)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Writer (censor, execWriterT, tell)
 import Control.Parallel (parTraverse)
+import Ctl.Internal.Contract.Hooks (ClusterParameters)
 import Ctl.Internal.Test.ContractTest
   ( ContractTest(ContractTest)
   , ContractTestPlan(ContractTestPlan)
@@ -62,7 +63,7 @@ import Ctl.Internal.Testnet.DistributeFunds
   )
 import Ctl.Internal.Testnet.DistributeFunds (Tx(Tx)) as DistrFunds
 import Ctl.Internal.Testnet.Server
-  ( StartedTestnetCluster
+  ( StartedTestnetCluster(StartedTestnetCluster)
   , makeClusterContractEnv
   , mkLogging
   , startTestnetCluster
@@ -77,8 +78,8 @@ import Ctl.Internal.Testnet.Utils
 import Data.Array (concat, fromFoldable, zip) as Array
 import Data.Bifunctor (lmap)
 import Data.Map (values) as Map
+import Effect.Aff (apathize, try)
 import Effect.Aff (bracket) as Aff
-import Effect.Aff (try)
 import Effect.Exception (error)
 import Effect.Ref (Ref)
 import Effect.Ref (new, read, write) as Ref
@@ -243,9 +244,17 @@ startTestnetContractEnv
 startTestnetContractEnv cfg distr cleanupRef = do
   _ <- cleanupOnExit cleanupRef
   logging@{ logger } <- liftEffect $ mkLogging cfg
-  cluster <- startTestnetCluster cfg cleanupRef logger
+  cluster@(StartedTestnetCluster { paths: { nodeSocketPath, nodeConfigPath } }) <-
+    startTestnetCluster cfg cleanupRef logger
   { env, printLogs, clearLogs } <- makeClusterContractEnv cleanupRef logging
   wallets <- mkWallets env cluster
+  let
+    clusterParams :: ClusterParameters
+    clusterParams =
+      { nodeSocketPath
+      , nodeConfigPath
+      }
+  apathize $ liftEffect $ for_ env.hooks.onClusterStartup (_ $ clusterParams)
   pure
     { cluster
     , env

src/Internal/Testnet/Server.purs

@@ -1,6 +1,6 @@
 module Ctl.Internal.Testnet.Server
   ( Channels
-  , StartedTestnetCluster(MkStartedTestnetCluster)
+  , StartedTestnetCluster(StartedTestnetCluster)
   , startKupo
   , startOgmios
   , startTestnetCluster
@@ -103,7 +103,7 @@ type Channels a =
   , stdout :: EventSource a
   }
 
-newtype StartedTestnetCluster = MkStartedTestnetCluster
+newtype StartedTestnetCluster = StartedTestnetCluster
   { ogmios ::
       { process :: ManagedProcess
       , channels :: Channels String
@@ -224,7 +224,7 @@ startTestnetCluster cfg cleanupRef logger = do
   kupo <- annotateError "Could not start kupo"
     $ startKupo' { paths, workdir: workdirAbsolute }
 
-  pure $ MkStartedTestnetCluster
+  pure $ StartedTestnetCluster
     { paths
     , ogmios
     , kupo

test/Testnet.purs

@@ -26,6 +26,7 @@ import Mote.Monad (mapTest)
 import Mote.TestPlanM as Utils
 import Test.Ctl.BalanceTx.ChangeGeneration as ChangeGeneration
 import Test.Ctl.KupmiosM.AffInterface as KupmiosM.AffInterface
+import Test.Ctl.Testnet.ClusterParameters (runTest) as ClusterParameters
 import Test.Ctl.Testnet.Contract as Contract
 import Test.Ctl.Testnet.Contract.Assert as Assert
 import Test.Ctl.Testnet.Contract.Mnemonics as Mnemonics
@@ -64,6 +65,7 @@ main = interruptOnSignal SIGINT =<< launchAff do
           testTestnetContracts config OgmiosMempool.suite
           -- FIXME: ClusterParameters.runTest
           runTestnetTestPlan config SameWallets.suite
+          ClusterParameters.runTest
 
 {-
 configWithMaxExUnits :: PlutipConfig

test/Testnet/ClusterParameters.purs

@@ -0,0 +1,48 @@
+module Test.Ctl.Testnet.ClusterParameters
+  ( mkSuite
+  , runTest
+  ) where
+
+import Prelude
+
+import Contract.Log (logDebug')
+import Contract.Test (ContractTest, withWallets)
+import Contract.Test.Mote (TestPlanM)
+import Contract.Test.Testnet (defaultTestnetConfig, testTestnetContracts)
+import Ctl.Internal.Contract.Hooks (ClusterParameters)
+import Data.Maybe (Maybe(Just))
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Effect.Ref (Ref)
+import Effect.Ref as Ref
+import Mote (group, test)
+import Node.FS.Sync (exists)
+import Test.Spec.Assertions (shouldNotEqual, shouldReturn)
+
+runTest :: TestPlanM (Aff Unit) Unit
+runTest = do
+  clusterParamsRef <-
+    liftEffect $ Ref.new
+      { nodeSocketPath: mempty
+      , nodeConfigPath: mempty
+      }
+  testTestnetContracts
+    defaultTestnetConfig
+      { hooks = defaultTestnetConfig.hooks
+          { onClusterStartup = Just (flip Ref.write clusterParamsRef)
+          }
+      }
+    (mkSuite clusterParamsRef)
+
+mkSuite :: Ref ClusterParameters -> TestPlanM ContractTest Unit
+mkSuite ref = do
+  group "ClusterParameters" do
+    test "Reading cardano-testnet cluster parameters" do
+      withWallets unit \_ -> do
+        clusterParams <- liftEffect $ Ref.read ref
+        clusterParams.nodeSocketPath `shouldNotEqual` mempty
+        clusterParams.nodeConfigPath `shouldNotEqual` mempty
+        liftEffect (exists clusterParams.nodeSocketPath) `shouldReturn` true
+        liftEffect (exists clusterParams.nodeConfigPath) `shouldReturn` true
+        logDebug' $ "ClusterParameters: " <> show clusterParams
+        pure unit

test/Testnet/Contract.purs

@@ -46,7 +46,8 @@ import Contract.BalanceTxConstraints
   , mustUseAdditionalUtxos
   ) as BalanceTxConstraints
 import Contract.BalanceTxConstraints
-  ( mustNotSpendUtxosWithOutRefs
+  ( mustNotSpendUtxosWhere
+  , mustNotSpendUtxosWithOutRefs
   , mustUseCollateralUtxos
   )
 import Contract.Chain (currentTime, waitUntilSlot)
@@ -107,14 +108,15 @@ import Contract.Transaction
   , lookupTxHash
   , signTransaction
   , submit
+  , submitTxFromBlueprint
   , submitTxFromConstraints
   , withBalancedTx
   , withBalancedTxs
   )
 import Contract.TxConstraints (TxConstraints)
 import Contract.TxConstraints as Constraints
 import Contract.UnbalancedTx (mkUnbalancedTx, mkUnbalancedTxE)
-import Contract.Utxos (UtxoMap, utxosAt)
+import Contract.Utxos (UtxoMap, getUtxo, utxosAt)
 import Contract.Value (Coin(Coin), Value, coinToValue)
 import Contract.Value as Value
 import Contract.Wallet
@@ -163,7 +165,7 @@ import Ctl.Internal.Test.UtxoDistribution (TestWalletSpec)
 import Ctl.Internal.Types.Interval (getSlotLength)
 import Ctl.Internal.Wallet.Cip30Mock (withCip30Mock)
 import Data.Array (head, (!!))
-import Data.Array (singleton) as Array
+import Data.Array (replicate, singleton, take) as Array
 import Data.Either (Either(Left, Right), hush, isLeft, isRight)
 import Data.Foldable (fold, foldM, length)
 import Data.Lens (view)
@@ -198,6 +200,7 @@ import Test.Ctl.Testnet.Utils (getLockedInputs, submitAndLog)
 import Test.Ctl.Testnet.UtxoDistribution (checkUtxoDistribution)
 import Test.Spec.Assertions
   ( expectError
+  , fail
   , shouldEqual
   , shouldNotEqual
   , shouldReturn
@@ -281,6 +284,48 @@ suite = do
       withWallets distribution \_ → pure unit
 
   group "Contract interface" do
+    test "mustNotSpendUtxosWhere balancer constraint" do
+      let
+        distrSize = 10
+        distr = Array.replicate distrSize $ BigNum.fromInt 2_000_000
+      withWallets distr \alice ->
+        withKeyWallet alice do
+          address <- liftedM "Could not get wallet address" $ head <$>
+            getWalletAddresses
+          utxos <- liftedM "Could not get wallet utxos" getWalletUtxos
+          let
+            nonSpendableUtxos = Array.take (distrSize / 2) $ Map.toUnfoldable
+              utxos
+          { txHash } <- submitTxFromBlueprint
+            { buildSteps:
+                Array.singleton $ Pay $ TransactionOutput
+                  { address
+                  , amount: Value.lovelaceValueOf $ BigNum.fromInt 5_000_000
+                  , datum: Nothing
+                  , scriptRef: Nothing
+                  }
+            , balancer: defaultBalancer
+            , balancerCtx:
+                { balancerConstraints:
+                    mustNotSpendUtxosWhere
+                      ( \oref _ -> Map.member oref $ Map.fromFoldable
+                          nonSpendableUtxos
+                      )
+                , extraUtxos: Map.empty
+                }
+            }
+          awaitTxConfirmed txHash
+          traverse_
+            ( \(oref /\ _) ->
+                getUtxo oref >>= case _ of
+                  Just _ -> pure unit
+                  Nothing ->
+                    fail $
+                      "mustNotSpendUtxosWhere: an unspendable utxo has been spent: "
+                        <> show oref
+            )
+            nonSpendableUtxos
+
     test
       "mustUseCollateralUtxos should not fail if enough UTxOs are provided"
       do