cardano-testnet: add single entrypoint for starting Shelley Babbage and Cardano testnets

Author: MarcFontaine

cardano-node-chairman/test/Spec/Chairman/Cardano.hs

@@ -16,6 +16,7 @@ import qualified Hedgehog.Extras.Test.Base as H
 import qualified Hedgehog.Extras.Test.Process as H
 import qualified System.Directory as IO
 import qualified Test.Base as H
+import qualified Test.Runtime as H
 import qualified Testnet.Cardano as H
 import qualified Testnet.Conf as H
 
@@ -29,6 +30,6 @@ hprop_chairman = H.integration . H.runFinallies . H.workspace "chairman" $ \temp
   configurationTemplate <- H.noteShow $ base </> "configuration/defaults/byron-mainnet/configuration.yaml"
   conf <- H.mkConf (H.ProjectBase base) (H.YamlFilePath configurationTemplate) tempAbsPath' Nothing
 
-  allNodes <- fmap H.nodeName . H.allNodes <$> H.testnet H.defaultTestnetOptions conf
+  allNodes <- fmap H.nodeName . H.allNodes <$> H.cardanoTestnet H.defaultTestnetOptions conf
 
   chairmanOver 120 50 conf allNodes

cardano-node-chairman/test/Spec/Chairman/Shelley.hs

@@ -6,6 +6,7 @@ module Spec.Chairman.Shelley
 
 import           Control.Monad ((=<<))
 import           Data.Function
+import           Data.Functor
 import           Data.Maybe
 import           Spec.Chairman.Chairman (chairmanOver)
 import           System.FilePath ((</>))
@@ -15,6 +16,7 @@ import qualified Hedgehog.Extras.Test.Base as H
 import qualified Hedgehog.Extras.Test.Process as H
 import qualified System.Directory as IO
 import qualified Test.Base as H
+import qualified Test.Runtime as H
 import qualified Testnet.Conf as H
 import qualified Testnet.Shelley as H
 
@@ -28,6 +30,6 @@ hprop_chairman = H.integration . H.runFinallies . H.workspace "chairman" $ \temp
   configurationTemplate <- H.noteShow $ base </> "configuration/defaults/byron-mainnet/configuration.yaml"
   conf <- H.mkConf (H.ProjectBase base) (H.YamlFilePath configurationTemplate) tempAbsPath' Nothing
 
-  allNodes <- H.testnet H.defaultTestnetOptions conf
+  allNodes <- fmap H.nodeName . H.allNodes <$> H.shelleyTestnet H.defaultTestnetOptions conf
 
   chairmanOver 120 21 conf allNodes

cardano-testnet/cardano-testnet.cabal

@@ -57,6 +57,7 @@ library
                         Test.Base
                         Test.Process
                         Test.Runtime
+                        Testnet
                         Testnet.Babbage
                         Testnet.Byron
                         Testnet.Cardano

cardano-testnet/src/Test/Process.hs

@@ -3,6 +3,7 @@ module Test.Process
   , assertByDeadlineMCustom
   , bashPath
   , execCli
+  , execCli_  
   , execCli'
   , execCreateScriptContext
   , execCreateScriptContext'
@@ -52,6 +53,13 @@ execCli
   -> m String
 execCli = GHC.withFrozenCallStack $ H.execFlex "cardano-cli" "CARDANO_CLI"
 
+-- | Run cardano-cli, discarding return value
+execCli_
+  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
+  => [String]
+  -> m ()
+execCli_ = void . execCli
+
 -- | Run cardano-cli, returning the stdout
 execCli'
   :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)

cardano-testnet/src/Test/Runtime.hs

@@ -2,21 +2,22 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Test.Runtime
   ( LeadershipSlot(..)
   , NodeLoggingFormat(..)
   , PaymentKeyPair(..)
   , StakingKeyPair(..)
   , TestnetRuntime(..)
+  , NodeRuntime(..)
   , TestnetNode(..)
   , PoolNode(..)
   , PoolNodeKeys(..)
   , Delegator(..)
+  , allNodes
   , bftSprockets
   , poolSprockets
-  , poolNodeToTestnetNode
+  , poolNodeStdout
   , readNodeLoggingFormat
   ) where
 
@@ -49,7 +50,7 @@ data TestnetRuntime = TestnetRuntime
   , delegators :: [Delegator]
   }
 
-data TestnetNode = TestnetNode
+data NodeRuntime = NodeRuntime
   { nodeName :: String
   , nodeSprocket :: Sprocket
   , nodeStdinHandle :: IO.Handle
@@ -58,14 +59,11 @@ data TestnetNode = TestnetNode
   , nodeProcessHandle :: IO.ProcessHandle
   }
 
+newtype TestnetNode = TestnetNode {unTestnetNode :: NodeRuntime}
+
 data PoolNode = PoolNode
-  { poolNodeName :: String
-  , poolNodeSprocket :: Sprocket
-  , poolNodeStdinHandle :: IO.Handle
-  , poolNodeStdout :: FilePath
-  , poolNodeStderr :: FilePath
-  , poolNodeProcessHandle :: IO.ProcessHandle
-  , poolNodeKeys :: PoolNodeKeys
+  { poolRuntime :: NodeRuntime
+  , poolKeys :: PoolNodeKeys
   }
 
 data PoolNodeKeys = PoolNodeKeys
@@ -97,31 +95,20 @@ data LeadershipSlot = LeadershipSlot
   , slotTime    :: Text
   } deriving (Eq, Show, Generic, FromJSON)
 
-poolNodeToTestnetNode :: PoolNode -> TestnetNode
-poolNodeToTestnetNode PoolNode
-  { poolNodeName
-  , poolNodeSprocket
-  , poolNodeStdinHandle
-  , poolNodeStdout
-  , poolNodeStderr
-  , poolNodeProcessHandle
-  } = TestnetNode
-  { nodeName = poolNodeName
-  , nodeSprocket = poolNodeSprocket
-  , nodeStdinHandle = poolNodeStdinHandle
-  , nodeStdout = poolNodeStdout
-  , nodeStderr = poolNodeStderr
-  , nodeProcessHandle = poolNodeProcessHandle
-  }
+poolNodeStdout :: PoolNode -> FilePath
+poolNodeStdout = nodeStdout . poolRuntime
 
 bftSprockets :: TestnetRuntime -> [Sprocket]
-bftSprockets = fmap nodeSprocket . bftNodes
+bftSprockets = fmap (nodeSprocket . unTestnetNode) . bftNodes
 
 poolSprockets :: TestnetRuntime -> [Sprocket]
-poolSprockets = fmap poolNodeSprocket . poolNodes
+poolSprockets = fmap (nodeSprocket . poolRuntime) . poolNodes
 
 readNodeLoggingFormat :: String -> Either String NodeLoggingFormat
 readNodeLoggingFormat = \case
   "json" -> Right NodeLoggingFormatAsJson
   "text" -> Right NodeLoggingFormatAsText
   s -> Left $ "Unrecognised node logging format: " <> show s <> ".  Valid options: \"json\", \"text\""
+
+allNodes :: TestnetRuntime -> [NodeRuntime]
+allNodes tr = fmap unTestnetNode (bftNodes tr) <> fmap poolRuntime (poolNodes tr)

cardano-testnet/src/Testnet.hs

@@ -0,0 +1,27 @@
+module Testnet
+  ( TestnetOptions(..)  
+  , Testnet.testnet
+  ) where
+
+import           Data.Eq (Eq)
+import           Text.Show (Show)
+
+import qualified Hedgehog.Extras.Test.Base as H
+
+import           Testnet.Babbage
+import           Testnet.Cardano
+import           Testnet.Conf
+import           Testnet.Shelley
+
+data TestnetOptions 
+  =  ShelleyOnlyTestnetOptions ShelleyTestnetOptions
+  |  BabbageOnlyTestnetOptions BabbageTestnetOptions
+  |  CardanoOnlyTestnetOptions CardanoTestnetOptions
+  deriving (Eq, Show)
+
+testnet :: TestnetOptions -> Conf -> H.Integration TestnetRuntime
+testnet options = case options of
+  ShelleyOnlyTestnetOptions o -> shelleyTestnet o
+  BabbageOnlyTestnetOptions o -> babbageTestnet o
+  CardanoOnlyTestnetOptions o -> cardanoTestnet o
+  

cardano-testnet/src/Testnet/Babbage.hs

@@ -8,7 +8,7 @@
 {-# OPTIONS_GHC -Wno-unused-local-binds -Wno-unused-matches #-}
 
 module Testnet.Babbage
-  ( TestnetOptions(..)
+  ( BabbageTestnetOptions(..)
   , defaultTestnetOptions
   , TestnetNodeOptions(..)
   , defaultTestnetNodeOptions
@@ -17,64 +17,57 @@ module Testnet.Babbage
   , TestnetNode (..)
   , PaymentKeyPair(..)
 
-  , testnet
+  , babbageTestnet
   ) where
 
 import           Control.Applicative (Applicative (..))
-import           Control.Monad (Monad (..), fmap, forM, forM_, return, void, when, (=<<))
+import           Control.Monad
 import           Data.Aeson (encode, object, toJSON, (.=))
 import           Data.Bool (Bool (..))
 import           Data.Eq (Eq)
 import           Data.Function (flip, ($), (.))
-import           Data.Functor ((<$>), (<&>))
+import           Data.Functor
 import           Data.Int (Int)
-import           Data.Maybe (Maybe (..))
-import           Data.Ord (Ord ((<=)))
 import           Data.Semigroup (Semigroup ((<>)))
 import           Data.String (String)
 import           GHC.Float (Double)
-import           Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..))
 import           Hedgehog.Extras.Stock.Time (showUTCTimeSeconds)
 import           System.FilePath.Posix ((</>))
+
 import           Test.Runtime (Delegator (..), NodeLoggingFormat (..), PaymentKeyPair (..),
                    PoolNode (PoolNode), PoolNodeKeys (..), StakingKeyPair (..), TestnetNode (..),
                    TestnetRuntime (..))
+import           Testnet.Utils
 import           Text.Show (Show (show))
 
 import qualified Data.HashMap.Lazy as HM
 import qualified Data.List as L
 import qualified Data.Time.Clock as DTC
-import qualified Hedgehog as H
 import qualified Hedgehog.Extras.Stock.Aeson as J
-import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO
 import qualified Hedgehog.Extras.Stock.OS as OS
-import qualified Hedgehog.Extras.Stock.String as S
 import qualified Hedgehog.Extras.Test.Base as H
 import qualified Hedgehog.Extras.Test.File as H
-import qualified Hedgehog.Extras.Test.Process as H
 import qualified System.Info as OS
-import qualified System.IO as IO
-import qualified System.Process as IO
 import qualified Test.Assert as H
-import qualified Test.Process as H
 import qualified Testnet.Conf as H
 
+import           Test.Process (execCli_)
 {- HLINT ignore "Reduce duplication" -}
 {- HLINT ignore "Redundant <&>" -}
 {- HLINT ignore "Redundant flip" -}
 {- HLINT ignore "Redundant id" -}
 {- HLINT ignore "Use let" -}
 
-data TestnetOptions = TestnetOptions
+data BabbageTestnetOptions = BabbageTestnetOptions
   { numSpoNodes :: Int
   , slotDuration :: Int
   , securityParam :: Int
   , totalBalance :: Int
   , nodeLoggingFormat :: NodeLoggingFormat
   } deriving (Eq, Show)
 
-defaultTestnetOptions :: TestnetOptions
-defaultTestnetOptions = TestnetOptions
+defaultTestnetOptions :: BabbageTestnetOptions
+defaultTestnetOptions = BabbageTestnetOptions
   { numSpoNodes = 3
   , slotDuration = 1000
   , securityParam = 10
@@ -92,8 +85,8 @@ defaultTestnetNodeOptions = TestnetNodeOptions
 startTimeOffsetSeconds :: DTC.NominalDiffTime
 startTimeOffsetSeconds = if OS.isWin32 then 90 else 15
 
-testnet :: TestnetOptions -> H.Conf -> H.Integration TestnetRuntime
-testnet testnetOptions H.Conf {..} = do
+babbageTestnet :: BabbageTestnetOptions -> H.Conf -> H.Integration TestnetRuntime
+babbageTestnet testnetOptions H.Conf {..} = do
   H.createDirectoryIfMissing (tempAbsPath </> "logs")
 
   H.lbsWriteFile (tempAbsPath </> "byron.genesis.spec.json") . encode $ object
@@ -124,7 +117,7 @@ testnet testnetOptions H.Conf {..} = do
   currentTime <- H.noteShowIO DTC.getCurrentTime
   startTime <- H.noteShow $ DTC.addUTCTime startTimeOffsetSeconds currentTime
 
-  void . H.execCli $
+  execCli_
     [ "byron", "genesis", "genesis"
     , "--protocol-magic", show @Int testnetMagic
     , "--start-time", showUTCTimeSeconds startTime
@@ -180,7 +173,7 @@ testnet testnetOptions H.Conf {..} = do
 
   let numPoolNodes = 3 :: Int
 
-  void . H.execCli $
+  execCli_
     [ "genesis", "create-staked"
     , "--genesis-dir", tempAbsPath
     , "--testnet-magic", show @Int testnetMagic
@@ -340,49 +333,19 @@ testnet testnetOptions H.Conf {..} = do
       ]
     ]
 
-  (poolSprockets, poolStdins, poolStdouts, poolStderrs, poolProcessHandles) <- fmap L.unzip5 . forM spoNodes $ \node -> do
-    dbDir <- H.noteShow $ tempAbsPath </> "db/" <> node
-    nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log"
-    nodeStderrFile <- H.noteTempFile logDir $ node <> ".stderr.log"
-    sprocket <- H.noteShow $ Sprocket tempBaseAbsPath (socketDir </> node)
-
-    H.createDirectoryIfMissing dbDir
-    H.createDirectoryIfMissing $ tempBaseAbsPath </> socketDir
-
-    hNodeStdout <- H.openFile nodeStdoutFile IO.WriteMode
-    hNodeStderr <- H.openFile nodeStderrFile IO.WriteMode
-
-    H.diff (L.length (IO.sprocketArgumentName sprocket)) (<=) IO.maxSprocketArgumentNameLength
-
-    portString <- fmap S.strip . H.readFile $ tempAbsPath </> node </> "port"
-
-    (Just stdIn, _, _, hProcess, _) <- H.createProcess =<<
-      ( H.procNode
+  poolNodes <- forM (L.zip spoNodes poolKeys) $ \(node,key) -> do
+    runtime <- startNode socketDir tempBaseAbsPath tempAbsPath logDir node
         [ "run"
         , "--config", tempAbsPath </> "configuration.yaml"
         , "--topology", tempAbsPath </> node </> "topology.json"
         , "--database-path", tempAbsPath </> node </> "db"
-        , "--socket-path", IO.sprocketArgumentName sprocket
         , "--shelley-kes-key", tempAbsPath </> node </> "kes.skey"
         , "--shelley-vrf-key", tempAbsPath </> node </> "vrf.skey"
         , "--byron-delegation-certificate", tempAbsPath </> node </> "byron-delegation.cert"
         , "--byron-signing-key", tempAbsPath </> node </> "byron-delegate.key"
         , "--shelley-operational-certificate", tempAbsPath </> node </> "opcert.cert"
-        , "--port",  portString
-        ] <&>
-        ( \cp -> cp
-          { IO.std_in = IO.CreatePipe
-          , IO.std_out = IO.UseHandle hNodeStdout
-          , IO.std_err = IO.UseHandle hNodeStderr
-          , IO.cwd = Just tempBaseAbsPath
-          }
-        )
-      )
-
-    when (OS.os `L.elem` ["darwin", "linux"]) $ do
-      H.onFailure . H.noteIO_ $ IO.readProcess "lsof" ["-iTCP:" <> portString, "-sTCP:LISTEN", "-n", "-P"] ""
-
-    return (sprocket, stdIn, nodeStdoutFile, nodeStderrFile, hProcess)
+        ]
+    return $ PoolNode runtime key
 
   now <- H.noteShowIO DTC.getCurrentTime
   deadline <- H.noteShow $ DTC.addUTCTime 90 now
@@ -401,14 +364,7 @@ testnet testnetOptions H.Conf {..} = do
     { configurationFile
     , shelleyGenesisFile = tempAbsPath </> "genesis/shelley/genesis.json"
     , testnetMagic
-    , poolNodes = L.zipWith7 PoolNode
-        spoNodes
-        poolSprockets
-        poolStdins
-        poolStdouts
-        poolStderrs
-        poolProcessHandles
-        poolKeys
+    , poolNodes
     , wallets = wallets
     , bftNodes = []
     , delegators = delegators