Restore onClusterStartup hook for cardano-testnet

src/Internal/BalanceTx/ExUnitsAndMinFee.purs

@@ -68,14 +68,7 @@ import Data.Foldable (foldMap)
 import Data.Lens ((.~))
 import Data.Lens.Getter ((^.))
 import Data.Map (Map)
-import Data.Map
-  ( empty
-  , filterKeys
-  , fromFoldable
-  , lookup
-  , toUnfoldable
-  , union
-  ) as Map
+import Data.Map (empty, filterKeys, fromFoldable, lookup, toUnfoldable, union) as Map
 import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
 import Data.Newtype (unwrap, wrap)
 import Data.Set (Set)
@@ -84,6 +77,7 @@ import Data.Traversable (for, sum)
 import Data.Tuple (snd)
 import Data.Tuple.Nested (type (/\), (/\))
 import Data.UInt as UInt
+import Effect.Aff (attempt)
 import Effect.Aff.Class (liftAff)
 import Effect.Class (liftEffect)
 
@@ -104,19 +98,25 @@ evalTxExecutionUnits tx = do
   worker :: Ogmios.AdditionalUtxoSet -> BalanceTxM Ogmios.TxEvaluationResult
   worker additionalUtxos = do
     queryHandle <- liftContract getQueryHandle
-    evalResult <-
-      unwrap <$> liftContract
-        (liftAff $ queryHandle.evaluateTx tx additionalUtxos)
-    case evalResult of
-      Right a -> pure a
-      Left (Ogmios.AdditionalUtxoOverlap overlappingUtxos) ->
-        -- Remove overlapping additional utxos and retry evaluation:
-        worker $ wrap $ Map.filterKeys (flip Array.notElem overlappingUtxos)
-          (unwrap additionalUtxos)
-      Left evalFailure | tx ^. _isValid ->
-        throwError $ ExUnitsEvaluationFailed tx evalFailure
+    evalResult' <-
+      map unwrap <$> liftContract
+        (liftAff $ attempt $ queryHandle.evaluateTx tx additionalUtxos)
+    case evalResult' of
+      Left err | tx ^. _isValid ->
+        liftAff $ throwError err
       Left _ ->
         pure $ wrap Map.empty
+      Right evalResult ->
+        case evalResult of
+          Right a -> pure a
+          Left (Ogmios.AdditionalUtxoOverlap overlappingUtxos) ->
+            -- Remove overlapping additional utxos and retry evaluation:
+            worker $ wrap $ Map.filterKeys (flip Array.notElem overlappingUtxos)
+              (unwrap additionalUtxos)
+          Left evalFailure | tx ^. _isValid -> do
+            throwError $ ExUnitsEvaluationFailed tx evalFailure
+          Left _ -> do
+            pure $ wrap Map.empty
 
 -- Calculates the execution units needed for each script in the transaction
 -- and the minimum fee, including the script fees.

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,7 @@ type Hooks =
   }
 
 type ClusterParameters =
-  { privateKeys :: Array PrivateKey
-  , nodeSocketPath :: String
-  , nodeConfigPath :: String
-  , privateKeysDirectory :: String
+  { nodeSocketPath :: FilePath
   }
 
 emptyHooks :: Hooks

src/Internal/Testnet/Contract.purs

@@ -77,8 +77,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
@@ -246,6 +246,11 @@ startTestnetContractEnv cfg distr cleanupRef = do
   { env, printLogs, clearLogs } <- makeClusterContractEnv cleanupRef cfg
   let env' = env { networkId = TestnetId }
   wallets <- mkWallets env' cluster
+  apathize $ liftEffect $
+    for_ env.hooks.onClusterStartup \onClusterStartup ->
+      onClusterStartup
+        { nodeSocketPath: (unwrap cluster).paths.nodeSocketPath
+        }
   pure
     { cluster
     , env: env'

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.QueryM.AffInterface as QueryM.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
@@ -63,7 +64,7 @@ main = interruptOnSignal SIGINT =<< launchAff do
           UtxoDistribution.suite
           testTestnetContracts config OgmiosMempool.suite
           runTestnetTestPlan config SameWallets.suite
--- FIXME: ClusterParameters.runTest
+          ClusterParameters.runTest
 
 {-
 configWithMaxExUnits :: PlutipConfig

test/Testnet/ClusterParameters.purs

@@ -0,0 +1,43 @@
+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 Test.Spec.Assertions (shouldNotEqual)
+
+runTest :: TestPlanM (Aff Unit) Unit
+runTest = do
+  clusterParamsRef <-
+    liftEffect $ Ref.new
+      { nodeSocketPath: 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
+        logDebug' $ "ClusterParameters: " <> show clusterParams
+        pure unit