(Re)Add http server monitoring to check cluster is ready

justfile

@@ -31,10 +31,10 @@ bench target:
 local-cluster:
   nix shell '.#local-cluster' '.#cardano-node' '.#cardano-wallet' \
     -c "local-cluster" \
-    monitoring \
+    controlling \
     --cluster-configs lib/local-cluster/test/data/cluster-configs \
     --faucet-funds ${FAUCET_FUNDS_FILE} \
-    --monitoring-port 12798 \
+    --control-port 12798 \
     --pulling-mode not-pulling
 
 # run unit tests on a match

lib/integration/framework/Test/Integration/Framework/Cluster/Launch.hs

@@ -38,7 +38,8 @@ import Cardano.Wallet.Launch.Cluster
     )
 import Cardano.Wallet.Launch.Cluster.CommandLine
     ( CommandLineOptions (..)
-    , Monitoring
+    , Monitoring (..)
+    , renderControl
     , renderMonitoring
     )
 import Cardano.Wallet.Launch.Cluster.Config
@@ -53,6 +54,9 @@ import Cardano.Wallet.Launch.Cluster.FileOf
 import Cardano.Wallet.Launch.Cluster.Node.RunningNode
     ( RunningNode (..)
     )
+import Cardano.Wallet.Network.Ports
+    ( getRandomPort
+    )
 import Control.Concurrent
     ( threadDelay
     )
@@ -64,7 +68,11 @@ import Control.Monad.Cont
     , evalContT
     )
 import Control.Monad.Trans
-    ( lift
+    ( MonadIO (..)
+    , lift
+    )
+import Control.Tracer
+    ( Tracer
     )
 import Data.Aeson
     ( FromJSON
@@ -103,22 +111,28 @@ import System.Process.Extra
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString as BS
 
-localClusterProcess
+withLocalClusterProcess
     :: CommandLineOptions
+    -> Tracer IO ClusterLog
     -> ClusterEra
-    -> ContT r IO CreateProcess
-localClusterProcess CommandLineOptions{..} era = do
+    -> ContT r IO ()
+withLocalClusterProcess CommandLineOptions{..} cfgTracer era = do
     myEnv <- lift getEnvironment
 
     let envs =
             [ ("LOCAL_CLUSTER_ERA", clusterEraToString era)
             ]
     output <- case clusterLogs of
-            Nothing -> pure Inherit
-            Just (FileOf logFile) ->
-                fmap UseHandle
-                    $ ContT $ withFile (toFilePath logFile) WriteMode
-    pure
+        Nothing -> pure Inherit
+        Just (FileOf logFile) ->
+            fmap UseHandle
+                $ ContT
+                $ withFile (toFilePath logFile) WriteMode
+
+    void
+        $ ContT
+        $ withBackendCreateProcess
+            (MsgLauncher "local-cluster" >$< cfgTracer)
         $ (proc "local-cluster" args)
             { env = Just $ myEnv ++ envs
             , -- , cwd = Just $ nodeDir cfg
@@ -127,13 +141,14 @@ localClusterProcess CommandLineOptions{..} era = do
             }
   where
     args =
-        renderMonitoring monitoring
-        <> [ "--cluster-configs"
-        , toFilePath $ absDirOf clusterConfigsDir
-        , "--faucet-funds"
-        , toFilePath $ absFileOf faucetFundsFile
-        ] <>
-            case clusterDir of
+        renderControl Nothing
+            <> renderMonitoring monitoring
+            <> [ "--cluster-configs"
+               , toFilePath $ absDirOf clusterConfigsDir
+               , "--faucet-funds"
+               , toFilePath $ absFileOf faucetFundsFile
+               ]
+            <> case clusterDir of
                 Nothing -> []
                 Just clusterDir' ->
                     [ "--cluster"
@@ -169,19 +184,17 @@ withGenesisData shelleyGenesis = ContT $ \f -> do
             >>= Aeson.throwDecodeStrict
     f genesisData
 
+-- | Run an action against a node socket,  backed by a local cluster process
 withLocalCluster
     :: HasCallStack
-    => Maybe Monitoring
-    -- ^ If to monitor the cluster.
-    -> Config
+    => Config
     -- ^ Configuration for the cluster.
     -> FaucetFunds
     -- ^ Initial faucet funds.
     -> (RunningNode -> IO a)
     -- ^ Action to run once when all pools have started.
     -> IO a
 withLocalCluster
-    monitoring
     Config{..}
     faucetFunds
     action = do
@@ -193,18 +206,21 @@ withLocalCluster
                         </> relFile "genesis-shelley.json"
             clusterDir = Just cfgClusterDir
             clusterLogs = cfgClusterLogFile
+            clusterControl = Nothing
+        monitoring <- do
+            httPort <- liftIO getRandomPort
+            pure $ Just $ Monitoring $ fromIntegral httPort
         evalContT $ do
             faucetFundsFile <- withFaucetFunds faucetFunds
-            socketPath <- withSocketPath
-                $ DirOf
-                $ absDirOf cfgClusterDir
-                    </> relDirOf cfgRelayNodePath
-            cp <- localClusterProcess CommandLineOptions{..} cfgLastHardFork
-            void
-                $ ContT
-                $ withBackendCreateProcess
-                    (MsgLauncher "local-cluster" >$< cfgTracer)
-                    cp
+            socketPath <-
+                withSocketPath
+                    $ DirOf
+                    $ absDirOf cfgClusterDir
+                        </> relDirOf cfgRelayNodePath
+            withLocalClusterProcess
+                CommandLineOptions{..}
+                cfgTracer
+                cfgLastHardFork
             lift $ threadDelay 10_000_000 -- when the cluster is ready ?
             genesisData <- withGenesisData shelleyGenesis
             lift

lib/integration/framework/Test/Integration/Framework/Setup.hs

@@ -342,7 +342,7 @@ withServer
             traceWith tr $ MsgInfo "Starting SMASH server ..."
             withSMASH tr' (toFilePath $ absDirOf testDir) $ \smashUrl -> do
                 traceWith tr $ MsgInfo "Starting local cluster ..."
-                withLocalCluster Nothing clusterConfig faucetFunds
+                withLocalCluster clusterConfig faucetFunds
                     $ onClusterStart
                         ctx
                         (onReady (T.pack smashUrl))

lib/local-cluster/exe/local-cluster.hs

@@ -4,17 +4,13 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 import Prelude
 
 import Cardano.BM.Extra
     ( stdoutTextTracer
     )
-import Cardano.BM.Tracing
-    ( nullTracer
-    )
 import Cardano.Launcher.Node
     ( nodeSocketFile
     )
@@ -30,7 +26,6 @@ import Cardano.Wallet.Launch.Cluster
     )
 import Cardano.Wallet.Launch.Cluster.CommandLine
     ( CommandLineOptions (..)
-    , Monitoring (..)
     , parseCommandLineOptions
     )
 import Cardano.Wallet.Launch.Cluster.FileOf
@@ -39,7 +34,7 @@ import Cardano.Wallet.Launch.Cluster.FileOf
     , mkRelDirOf
     )
 import Cardano.Wallet.Launch.Cluster.Monitoring.Monitor
-    ( withMonitor
+    ( withMonitoring
     )
 import Control.Concurrent
     ( threadDelay
@@ -159,13 +154,12 @@ main = withUtf8 $ do
         , clusterDir
         , monitoring
         , clusterLogs
+        , clusterControl
         } <-
         parseCommandLineOptions
     funds <- retrieveFunds faucetFundsFile
     flip runContT pure $ do
-        trace <- case monitoring of
-            Just Monitoring{..} -> ContT $ withMonitor monitoringPort pullingMode
-            Nothing -> pure nullTracer
+        trace <- withMonitoring clusterControl monitoring
         clusterPath <-
             case clusterDir of
                 Just path -> pure path

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs

@@ -7,10 +7,12 @@
 
 module Cardano.Wallet.Launch.Cluster.CommandLine
     ( CommandLineOptions (..)
+    , ClusterControl (..)
     , Monitoring (..)
     , parseCommandLineOptions
     , clusterConfigsDirParser
     , renderPullingMode
+    , renderControl
     , renderMonitoring
     ) where
 
@@ -56,35 +58,71 @@ import System.Path
     ( absRel
     )
 
-data Monitoring = Monitoring
-    { monitoringPort :: Port
+data ClusterControl = ClusterControl
+    { clusterControlPort :: Port
     , pullingMode :: MonitorState
     }
     deriving stock (Show)
 
+newtype Monitoring = Monitoring
+    { monitoringPort :: Port
+    }
+    deriving stock (Show)
+
 data CommandLineOptions = CommandLineOptions
     { clusterConfigsDir :: DirOf "cluster-configs"
     , faucetFundsFile :: FileOf "faucet-funds"
     , clusterDir :: Maybe (DirOf "cluster")
     , monitoring :: Maybe Monitoring
+    , clusterControl :: Maybe ClusterControl
     , clusterLogs :: Maybe (FileOf "cluster-logs")
     }
     deriving stock (Show)
 
 parseCommandLineOptions :: IO CommandLineOptions
 parseCommandLineOptions = do
     absolutizer <- newAbsolutizer
-    let options = monitoringParser $ do
+    let options = clusterControlParser $ do
             clusterConfigsDir <- clusterConfigsDirParser absolutizer
             faucetFundsFile <- faucetFundsParser absolutizer
             clusterDir <- clusterDirParser absolutizer
             clusterLogs <- clusterLogsParser absolutizer
-            pure $ \monitoring -> CommandLineOptions{..}
+            monitoring <- monitoringParser
+            pure $ \clusterControl -> CommandLineOptions{..}
     execParser
         $ info
             (options <**> helper)
             (progDesc "Local Cluster for testing")
 
+monitoringParser :: Parser (Maybe Monitoring)
+monitoringParser = optional $ Monitoring <$> httpPortParser
+
+renderMonitoring :: Maybe Monitoring -> [String]
+renderMonitoring (Just (Monitoring port)) =
+    [ "--monitoring-port"
+    , show port
+    ]
+renderMonitoring Nothing = []
+
+httpPortParser :: Parser Port
+httpPortParser = do
+    option
+        parse
+        ( long "monitoring-port"
+            <> metavar "MONITORING_PORT"
+            <> help "Port for the monitoring HTTP server"
+        )
+  where
+    parse = do
+        p <- auto
+        unless (p `elem` validPorts)
+            $ fail
+            $ "Invalid port number. Must be inside: "
+                ++ show (head validPorts)
+                ++ ".."
+                ++ show (last validPorts)
+        pure p
+
 clusterConfigsDirParser :: Absolutizer -> Parser (DirOf "cluster-configs")
 clusterConfigsDirParser (Absolutizer absOf) =
     DirOf . absOf . absRel
@@ -113,13 +151,13 @@ clusterDirParser (Absolutizer absOf) =
                     <> help "Path to the local cluster directory"
                 )
 
-portParser :: Parser Port
-portParser = do
+tcpPortParser :: Parser Port
+tcpPortParser = do
     option
         parse
-        ( long "monitoring-port"
-            <> metavar "MONITORING_PORT"
-            <> help "Port for the monitoring server"
+        ( long "control-port"
+            <> metavar "CONTROL_PORT"
+            <> help "Port for the TCP control server"
         )
   where
     parse = do
@@ -138,7 +176,7 @@ monitorStateParser = do
         parse
         ( long "pulling-mode"
             <> metavar "PULLING_MODE"
-            <> help "Mode for the monitoring server"
+            <> help "Mode for the control server"
         )
   where
     parse = eitherReader $ \case
@@ -154,33 +192,33 @@ renderPullingMode = \case
     NotPullingState -> "not-pulling"
     PullingState -> "pulling"
 
-renderMonitoring :: Maybe Monitoring -> [String]
-renderMonitoring (Just Monitoring{..})  =
-    [ "monitoring"
-    , "--monitoring-port", show monitoringPort
+renderControl :: Maybe ClusterControl -> [String]
+renderControl (Just ClusterControl{..})  =
+    [ "control"
+    , "--control-port", show clusterControlPort
     , "--pulling-mode", renderPullingMode pullingMode
     ]
-renderMonitoring Nothing =
-    [ "no-monitoring"
+renderControl Nothing =
+    [ "no-control"
     ]
 
-monitoringParser :: Parser (Maybe Monitoring -> a) -> Parser a
-monitoringParser f =
-    hsubparser $ monitoringCommand <> noMonitoring
+clusterControlParser :: Parser (Maybe ClusterControl -> a) -> Parser a
+clusterControlParser f =
+    hsubparser $ controlCommand <> noControl
   where
-    monitoringCommand =
-        command "monitoring"
-            $ info (f <*> yesMonitoringParser)
-            $ progDesc "Enable monitoring"
-    yesMonitoringParser =
+    controlCommand =
+        command "control"
+            $ info (f <*> yesControlParser)
+            $ progDesc "Enable control"
+    yesControlParser =
         fmap Just
-            $ Monitoring
-                <$> portParser
+            $ ClusterControl
+                <$> tcpPortParser
                 <*> monitorStateParser
-    noMonitoring =
-        command "no-monitoring"
+    noControl =
+        command "no-control"
             $ info (f <*> pure Nothing)
-            $ progDesc "Disable monitoring"
+            $ progDesc "Disable control"
 
 clusterLogsParser :: Absolutizer -> Parser (Maybe (FileOf "cluster-logs"))
 clusterLogsParser (Absolutizer absOf) =