From a197d3a3b92b2c92e4cf5ad4cd04794216521d87 Mon Sep 17 00:00:00 2001 From: paolino Date: Mon, 6 May 2024 14:16:58 +0000 Subject: [PATCH 01/11] Add monitoring to CLI options --- .../Wallet/Launch/Cluster/CommandLine.hs | 71 +++++++++++++++++++ 1 file changed, 71 insertions(+) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs index a151f701838..ff97c6c2b9e 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} module Cardano.Wallet.Launch.Cluster.CommandLine ( CommandLineOptions (..) @@ -16,14 +17,31 @@ import Cardano.Wallet.Launch.Cluster.FileOf , FileOf (..) , newAbsolutizer ) +import Cardano.Wallet.Launch.Cluster.Http.Service + ( ServiceConfiguration (..) + ) +import Cardano.Wallet.Network.Ports + ( PortNumber + ) +import Control.Monad + ( unless + ) +import Control.Monitoring.Tracing + ( MonitorState (..) + ) +import Data.Maybe + ( fromMaybe + ) import Options.Applicative ( Parser + , auto , execParser , help , helper , info , long , metavar + , option , optional , progDesc , strOption @@ -38,6 +56,7 @@ data CommandLineOptions = CommandLineOptions , clusterDir :: Maybe (DirOf "cluster") , clusterLogs :: Maybe (FileOf "cluster-logs") , nodeToClientSocket :: FileOf "node-to-client-socket" + , httpService :: ServiceConfiguration } deriving stock (Show) @@ -51,10 +70,62 @@ parseCommandLineOptions = do <*> clusterDirParser absolutizer <*> clusterLogsParser absolutizer <*> nodeToClientSocketParser absolutizer + <*> monitoringParser <**> helper ) (progDesc "Local Cluster for testing") +monitoringParser :: Parser ServiceConfiguration +monitoringParser = + mkServiceConfiguration + <$> httpApiPortParser + <*> controlInitalStateParser + where + mkServiceConfiguration port mstate = + ServiceConfiguration port + $ fromMaybe Run mstate + +controlInitalStateParser :: Parser (Maybe MonitorState) +controlInitalStateParser = + optional + $ option + parse + ( long "control-initial-state" + <> metavar "CONTROL_INITIAL_STATE" + <> help "Initial state of the control, wait, step or run" + ) + where + parse = do + s :: String <- auto + case s of + "wait" -> pure Wait + "step" -> pure Step + "run" -> pure Run + _ -> fail "Invalid control initial state" + +httpApiPortParser :: Parser (Maybe PortNumber) +httpApiPortParser = do + optional + $ 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 + +validPorts :: [PortNumber] +validPorts = [1024 .. 65535] + nodeToClientSocketParser :: Absolutizer -> Parser (FileOf "node-to-client-socket") nodeToClientSocketParser (Absolutizer absOf) = FileOf . absOf . absRel From 30a77f10d69fc882b90b38d20f3091cc433232f2 Mon Sep 17 00:00:00 2001 From: paolino Date: Mon, 6 May 2024 14:23:08 +0000 Subject: [PATCH 02/11] Add http api to local-cluster executable --- lib/local-cluster/exe/local-cluster.hs | 61 +++++++++++++++++++++----- lib/local-cluster/local-cluster.cabal | 2 + 2 files changed, 53 insertions(+), 10 deletions(-) diff --git a/lib/local-cluster/exe/local-cluster.hs b/lib/local-cluster/exe/local-cluster.hs index fbd24414881..659db81c014 100644 --- a/lib/local-cluster/exe/local-cluster.hs +++ b/lib/local-cluster/exe/local-cluster.hs @@ -40,6 +40,20 @@ import Cardano.Wallet.Launch.Cluster.FileOf , mkRelDirOf , toFilePath ) +import Cardano.Wallet.Launch.Cluster.Http.Faucet.Server + ( newNodeConnVar + ) +import Cardano.Wallet.Launch.Cluster.Http.Service + ( withServiceServer + ) +import Cardano.Wallet.Launch.Cluster.Monitoring.Phase + ( Phase (..) + , RelayNode (..) + ) +import Cardano.Wallet.Primitive.NetworkId + ( NetworkId (..) + , withSNetworkId + ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) @@ -56,6 +70,13 @@ import Control.Monad.Cont import Control.Monad.IO.Class ( MonadIO (..) ) +import Control.Tracer + ( Tracer (..) + , traceWith + ) +import Data.Text.Class + ( ToText + ) import Main.Utf8 ( withUtf8 ) @@ -211,7 +232,8 @@ main = withUtf8 $ do setDefaultFilePermissions skipCleanup <- SkipCleanup <$> isEnvSet "NO_CLEANUP" - let tr = stdoutTextTracer + let tr :: ToText a => Tracer IO a + tr = stdoutTextTracer clusterEra <- Cluster.clusterEraFromEnv cfgNodeLogging <- Cluster.logFileConfigFromEnv @@ -223,6 +245,7 @@ main = withUtf8 $ do , clusterDir , clusterLogs , nodeToClientSocket + , httpService } <- parseCommandLineOptions evalContT $ do @@ -231,15 +254,9 @@ main = withUtf8 $ do case clusterDir of Just path -> pure path Nothing -> - fmap (DirOf . absDir) $ - ContT $ withSystemTempDir tr "test-cluster" skipCleanup - -- Start the faucet - faucetClientEnv <- ContT withFaucet - maryAllegraFunds <- - liftIO - $ runFaucetM faucetClientEnv - $ Faucet.maryAllegraFunds (Coin 10_000_000) shelleyTestnet - -- Start the cluster + fmap (DirOf . absDir) + $ ContT + $ withSystemTempDir tr "test-cluster" skipCleanup let clusterCfg = Cluster.Config { cfgStakePools = Cluster.defaultPoolConfigs @@ -255,6 +272,23 @@ main = withUtf8 $ do , cfgClusterLogFile = clusterLogs , cfgNodeToClientSocket = nodeToClientSocket } + (_, phaseTracer) <- withSNetworkId (NTestnet 42) + $ \network -> do + nodeConn <- liftIO newNodeConnVar + withServiceServer + network + nodeConn + clusterCfg + tr + httpService + -- Start the faucet + faucetClientEnv <- ContT withFaucet + maryAllegraFunds <- + liftIO + $ runFaucetM faucetClientEnv + $ Faucet.maryAllegraFunds (Coin 10_000_000) shelleyTestnet + -- Start the cluster + node <- ContT $ Cluster.withCluster @@ -287,7 +321,14 @@ main = withUtf8 $ do $ clusterDirPath relFile "byron-genesis.json" } + (_walletInstance, _walletApi) <- ContT $ bracket (WC.start walletProcessConfig) (WC.stop . fst) + liftIO + $ traceWith phaseTracer + $ Cluster + $ Just + $ RelayNode + $ toFilePath nodeSocket -- Wait forever or ctrl-c threadDelay maxBound diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index ad07c202e26..fe61a4953bd 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -175,6 +175,7 @@ executable local-cluster , cardano-wallet-application-extras , cardano-wallet-launcher , cardano-wallet-primitive + , contra-tracer , directory , iohk-monitoring-extra , lens @@ -182,6 +183,7 @@ executable local-cluster , mtl , pathtype , temporary-extra + , text-class , unliftio , with-utf8 From a2cc7e4356c288dde49dbfbf4d6fe937ba129d8b Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 8 May 2024 10:41:52 +0000 Subject: [PATCH 03/11] Add a simplified thread safe tracer for `ToText` instances --- .../iohk-monitoring-extra.cabal | 12 ++- .../src/Cardano/BM/ToTextTracer.hs | 97 +++++++++++++++++++ 2 files changed, 105 insertions(+), 4 deletions(-) create mode 100644 lib/iohk-monitoring-extra/src/Cardano/BM/ToTextTracer.hs diff --git a/lib/iohk-monitoring-extra/iohk-monitoring-extra.cabal b/lib/iohk-monitoring-extra/iohk-monitoring-extra.cabal index da5018e4dd3..6d1d1b975e5 100644 --- a/lib/iohk-monitoring-extra/iohk-monitoring-extra.cabal +++ b/lib/iohk-monitoring-extra/iohk-monitoring-extra.cabal @@ -11,8 +11,8 @@ build-type: Simple library default-language: Haskell2010 default-extensions: - NoImplicitPrelude DerivingStrategies + NoImplicitPrelude OverloadedStrings ghc-options: @@ -25,7 +25,10 @@ library -freverse-errors hs-source-dirs: src - exposed-modules: Cardano.BM.Extra + exposed-modules: + Cardano.BM.Extra + Cardano.BM.ToTextTracer + build-depends: , aeson , base @@ -34,9 +37,10 @@ library , deepseq , exceptions , fmt - , iohk-monitoring ^>=0.1.11.3 + , iohk-monitoring + , stm , text - , text-class ^>=2024.5.5 + , text-class , time , tracer-transformers , transformers diff --git a/lib/iohk-monitoring-extra/src/Cardano/BM/ToTextTracer.hs b/lib/iohk-monitoring-extra/src/Cardano/BM/ToTextTracer.hs new file mode 100644 index 00000000000..c7f97350b3a --- /dev/null +++ b/lib/iohk-monitoring-extra/src/Cardano/BM/ToTextTracer.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE RankNTypes #-} + +module Cardano.BM.ToTextTracer + ( ToTextTracer (..) + , newToTextTracer + ) +where + +import Prelude + +import Cardano.BM.Data.Tracer + ( HasSeverityAnnotation (..) + , Tracer (Tracer) + ) +import Cardano.BM.Tracing + ( Severity + ) +import Control.Monad + ( forever + , unless + , (>=>) + ) +import Control.Monad.STM + ( retry + ) +import Control.Monad.Trans.Cont + ( ContT (..) + ) +import Data.Text.Class + ( ToText (..) + ) +import Data.Time + ( getCurrentTime + ) +import Data.Time.Format.ISO8601 + ( iso8601Show + ) +import UnliftIO + ( BufferMode (NoBuffering) + , IOMode (WriteMode) + , MonadIO (liftIO) + , async + , atomically + , hSetBuffering + , isEmptyTChan + , link + , newTChanIO + , readTChan + , stdout + , withFile + , writeTChan + ) + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +-- | A thread-safe tracer that logs messages to a file or stdout for anything +-- that has ToText instance +newtype ToTextTracer + = ToTextTracer + (forall a. (HasSeverityAnnotation a, ToText a) => Tracer IO a) + +-- | Create a new `ToTextTracer` +newToTextTracer + :: Maybe FilePath + -- ^ If provided, logs will be written to this file, otherwise to stdout + -> Maybe Severity + -- ^ Minimum severity level to log + -> (ToTextTracer -> IO r) + -- ^ Action to run with the new tracer + -> IO r +newToTextTracer clusterLogs minSeverity = runContT $ do + ch <- newTChanIO + h <- case clusterLogs of + Nothing -> pure stdout + Just logFile -> do + ContT $ withFile logFile WriteMode + liftIO $ hSetBuffering h NoBuffering + liftIO $ async >=> link $ forever $ do + (x, s, t) <- atomically $ readTChan ch + T.hPutStrLn h + $ T.pack (iso8601Show t) + <> " [" + <> T.pack (show s) + <> "] " + <> x + ContT $ \k -> do + r <- k $ ToTextTracer $ Tracer $ \msg -> do + let severity = getSeverityAnnotation msg + unless (Just severity < minSeverity) $ do + t <- getCurrentTime + atomically $ writeTChan ch (toText msg, severity, t) + -- wait until the channel is empty + atomically $ do + empty <- isEmptyTChan ch + unless empty retry + pure r From e474c1384beec611fe32a6b66e93b0a48a1a6baf Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 8 May 2024 10:52:24 +0000 Subject: [PATCH 04/11] Add severity to MsgHttpMonitoring --- .../Cardano/Wallet/Launch/Cluster/Http/Logging.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Logging.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Logging.hs index 3ea0874b957..3cbac0a428b 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Logging.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Logging.hs @@ -8,6 +8,10 @@ where import Prelude +import Cardano.BM.Tracing + ( HasSeverityAnnotation (..) + , Severity (..) + ) import Cardano.Wallet.Launch.Cluster.Http.Client ( MsgClient ) @@ -45,3 +49,13 @@ instance ToText MsgHttpService where "HTTP monitoring client stopped" MsgHttpServiceDone -> "HTTP monitoring done" + +instance HasSeverityAnnotation MsgHttpService where + getSeverityAnnotation = \case + MsgHttpServicePort _ -> Info + MsgHttpServiceQuery _ -> Info + MsgHttpServiceServerStarted -> Info + MsgHttpServiceServerStopped -> Info + MsgHttpServiceClientStarted -> Info + MsgHttpServiceClientStopped -> Info + MsgHttpServiceDone -> Info From 187e8db9049fad9d492a2afcd941aff9ee908b76 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 8 May 2024 10:47:05 +0000 Subject: [PATCH 05/11] Use the `ToTextTracer` in local-cluster exe --- lib/local-cluster/exe/local-cluster.hs | 23 +++++++++++++---------- lib/local-cluster/local-cluster.cabal | 1 - 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/lib/local-cluster/exe/local-cluster.hs b/lib/local-cluster/exe/local-cluster.hs index 659db81c014..1b9c3ac5cf2 100644 --- a/lib/local-cluster/exe/local-cluster.hs +++ b/lib/local-cluster/exe/local-cluster.hs @@ -12,8 +12,9 @@ import Prelude import Cardano.Address.Style.Shelley ( shelleyTestnet ) -import Cardano.BM.Extra - ( stdoutTextTracer +import Cardano.BM.ToTextTracer + ( ToTextTracer (..) + , newToTextTracer ) import Cardano.Launcher.Node ( nodeSocketFile @@ -71,11 +72,7 @@ import Control.Monad.IO.Class ( MonadIO (..) ) import Control.Tracer - ( Tracer (..) - , traceWith - ) -import Data.Text.Class - ( ToText + ( traceWith ) import Main.Utf8 ( withUtf8 @@ -232,8 +229,7 @@ main = withUtf8 $ do setDefaultFilePermissions skipCleanup <- SkipCleanup <$> isEnvSet "NO_CLEANUP" - let tr :: ToText a => Tracer IO a - tr = stdoutTextTracer + clusterEra <- Cluster.clusterEraFromEnv cfgNodeLogging <- Cluster.logFileConfigFromEnv @@ -249,6 +245,13 @@ main = withUtf8 $ do } <- parseCommandLineOptions evalContT $ do + -- Add a tracer for the cluster logs + ToTextTracer tr <- + ContT + $ newToTextTracer + (toFilePath . absFileOf <$> clusterLogs) + Nothing + -- Create a temporary directory for the cluster clusterPath <- case clusterDir of @@ -266,7 +269,7 @@ main = withUtf8 $ do , cfgClusterConfigs = clusterConfigsDir , cfgTestnetMagic = Cluster.TestnetMagic 42 , cfgShelleyGenesisMods = [over #sgSlotLength \_ -> 0.2] - , cfgTracer = stdoutTextTracer + , cfgTracer = tr , cfgNodeOutputFile = Nothing , cfgRelayNodePath = mkRelDirOf "relay" , cfgClusterLogFile = clusterLogs diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index fe61a4953bd..d146f90c769 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -183,7 +183,6 @@ executable local-cluster , mtl , pathtype , temporary-extra - , text-class , unliftio , with-utf8 From 41d8396a2d568c5a9a5ac49656a2910cf8bfa357 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 8 May 2024 11:07:53 +0000 Subject: [PATCH 06/11] Add minSeverity option to local-cluster CLI --- lib/local-cluster/exe/local-cluster.hs | 3 +- .../Wallet/Launch/Cluster/CommandLine.hs | 30 +++++++++++++++++++ 2 files changed, 32 insertions(+), 1 deletion(-) diff --git a/lib/local-cluster/exe/local-cluster.hs b/lib/local-cluster/exe/local-cluster.hs index 1b9c3ac5cf2..a56062eaeca 100644 --- a/lib/local-cluster/exe/local-cluster.hs +++ b/lib/local-cluster/exe/local-cluster.hs @@ -242,6 +242,7 @@ main = withUtf8 $ do , clusterLogs , nodeToClientSocket , httpService + , minSeverity } <- parseCommandLineOptions evalContT $ do @@ -250,7 +251,7 @@ main = withUtf8 $ do ContT $ newToTextTracer (toFilePath . absFileOf <$> clusterLogs) - Nothing + minSeverity -- Create a temporary directory for the cluster clusterPath <- diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs index ff97c6c2b9e..fe9176dc827 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs @@ -11,6 +11,9 @@ where import Prelude +import Cardano.BM.Data.Severity + ( Severity + ) import Cardano.Wallet.Launch.Cluster.FileOf ( Absolutizer (..) , DirOf (..) @@ -51,10 +54,13 @@ import System.Path ( absRel ) +import qualified Cardano.BM.Data.Severity as Severity + data CommandLineOptions = CommandLineOptions { clusterConfigsDir :: DirOf "cluster-configs" , clusterDir :: Maybe (DirOf "cluster") , clusterLogs :: Maybe (FileOf "cluster-logs") + , minSeverity :: Maybe Severity , nodeToClientSocket :: FileOf "node-to-client-socket" , httpService :: ServiceConfiguration } @@ -69,12 +75,36 @@ parseCommandLineOptions = do <$> clusterConfigsDirParser absolutizer <*> clusterDirParser absolutizer <*> clusterLogsParser absolutizer + <*> minSeverityParser <*> nodeToClientSocketParser absolutizer <*> monitoringParser <**> helper ) (progDesc "Local Cluster for testing") +minSeverityParser :: Parser (Maybe Severity) +minSeverityParser = + optional + $ option + parse + ( long "min-severity" + <> metavar "MIN_SEVERITY" + <> help "Minimum severity level for logging" + ) + where + parse = do + s :: String <- auto + case s of + "Debug" -> pure Severity.Debug + "Info" -> pure Severity.Info + "Notice" -> pure Severity.Notice + "Warning" -> pure Severity.Warning + "Error" -> pure Severity.Error + "Critical" -> pure Severity.Critical + "Alert" -> pure Severity.Alert + "Emergency" -> pure Severity.Emergency + _ -> fail "Invalid severity level" + monitoringParser :: Parser ServiceConfiguration monitoringParser = mkServiceConfiguration From b258bc8513ed9e50029081061ebdd6f749d9793c Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 8 May 2024 11:25:00 +0000 Subject: [PATCH 07/11] Make the socket-path option optional --- lib/local-cluster/exe/local-cluster.hs | 10 ++++++++-- .../Wallet/Launch/Cluster/CommandLine.hs | 19 +++++++++++-------- lib/local-cluster/local-cluster.cabal | 1 + 3 files changed, 20 insertions(+), 10 deletions(-) diff --git a/lib/local-cluster/exe/local-cluster.hs b/lib/local-cluster/exe/local-cluster.hs index a56062eaeca..a03c126396e 100644 --- a/lib/local-cluster/exe/local-cluster.hs +++ b/lib/local-cluster/exe/local-cluster.hs @@ -83,6 +83,9 @@ import System.Directory import System.Environment.Extended ( isEnvSet ) +import System.IO.Extra + ( withTempFile + ) import System.IO.Temp.Extra ( SkipCleanup (..) , withSystemTempDir @@ -92,7 +95,7 @@ import System.Path , parse , relDir , relFile - , () + , (), absFile ) import UnliftIO.Concurrent ( threadDelay @@ -261,6 +264,9 @@ main = withUtf8 $ do fmap (DirOf . absDir) $ ContT $ withSystemTempDir tr "test-cluster" skipCleanup + socketPath <- case nodeToClientSocket of + Just path -> pure path + Nothing -> FileOf . absFile <$> ContT withTempFile let clusterCfg = Cluster.Config { cfgStakePools = Cluster.defaultPoolConfigs @@ -274,7 +280,7 @@ main = withUtf8 $ do , cfgNodeOutputFile = Nothing , cfgRelayNodePath = mkRelDirOf "relay" , cfgClusterLogFile = clusterLogs - , cfgNodeToClientSocket = nodeToClientSocket + , cfgNodeToClientSocket = socketPath } (_, phaseTracer) <- withSNetworkId (NTestnet 42) $ \network -> do diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs index fe9176dc827..2ea4e9e1d8b 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs @@ -61,7 +61,7 @@ data CommandLineOptions = CommandLineOptions , clusterDir :: Maybe (DirOf "cluster") , clusterLogs :: Maybe (FileOf "cluster-logs") , minSeverity :: Maybe Severity - , nodeToClientSocket :: FileOf "node-to-client-socket" + , nodeToClientSocket :: Maybe (FileOf "node-to-client-socket") , httpService :: ServiceConfiguration } deriving stock (Show) @@ -156,14 +156,17 @@ httpApiPortParser = do validPorts :: [PortNumber] validPorts = [1024 .. 65535] -nodeToClientSocketParser :: Absolutizer -> Parser (FileOf "node-to-client-socket") +nodeToClientSocketParser + :: Absolutizer + -> Parser (Maybe (FileOf "node-to-client-socket")) nodeToClientSocketParser (Absolutizer absOf) = - FileOf . absOf . absRel - <$> strOption - ( long "socket-path" - <> metavar "NODE_TO_CLIENT_SOCKET" - <> help "Path to the node-to-client socket" - ) + optional + $ FileOf . absOf . absRel + <$> strOption + ( long "socket-path" + <> metavar "NODE_TO_CLIENT_SOCKET" + <> help "Path to the node-to-client socket" + ) clusterConfigsDirParser :: Absolutizer -> Parser (DirOf "cluster-configs") clusterConfigsDirParser (Absolutizer absOf) = diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index d146f90c769..55f1a78071f 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -177,6 +177,7 @@ executable local-cluster , cardano-wallet-primitive , contra-tracer , directory + , extra , iohk-monitoring-extra , lens , local-cluster From f629787d62e78998e84976d52433c455f3167539 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 8 May 2024 11:34:00 +0000 Subject: [PATCH 08/11] Fix Command Show instance --- lib/launcher/src/Cardano/Launcher.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/launcher/src/Cardano/Launcher.hs b/lib/launcher/src/Cardano/Launcher.hs index eb718198e9e..e73ee5334b1 100644 --- a/lib/launcher/src/Cardano/Launcher.hs +++ b/lib/launcher/src/Cardano/Launcher.hs @@ -65,6 +65,9 @@ import Data.Text import Data.Text.Class ( ToText (..) ) +import Data.Text.Lazy.Builder + ( toLazyText + ) import Fmt ( Buildable (..) , Builder @@ -124,6 +127,7 @@ import UnliftIO.Process ) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL -- | Represent a command to execute. Args are provided as a list where options -- are expected to be prefixed with `--` or `-`. For example: @@ -149,7 +153,7 @@ data Command = Command } deriving (Generic) instance Show Command where - show = show . build + show = TL.unpack . toLazyText . build instance Eq Command where a == b = build a == build b From b0b3ef1f13e8d95ce82857b02e1d08921e9a863b Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 7 May 2024 10:44:26 +0000 Subject: [PATCH 09/11] Add tests for the application http API --- .buildkite/pipeline.yml | 9 ++ justfile | 3 + lib/local-cluster/local-cluster.cabal | 9 +- .../Wallet/Launch/Cluster/Http/ServiceSpec.hs | 122 +++++++++++++++++- 4 files changed, 137 insertions(+), 6 deletions(-) diff --git a/.buildkite/pipeline.yml b/.buildkite/pipeline.yml index eabf977bcc3..cf423b49d7e 100644 --- a/.buildkite/pipeline.yml +++ b/.buildkite/pipeline.yml @@ -55,6 +55,15 @@ steps: env: TMPDIR: "/cache" + - label: Run local-cluster tests + key: local-cluster-tests + depends_on: linux-nix + command: nix shell .#local-cluster -c cabal test -O0 local-cluster + agents: + system: ${linux} + env: + TMPDIR: "/cache" + - label: "Babbage integration tests (linux)" key: linux-tests-integration-babbage depends_on: linux-nix diff --git a/justfile b/justfile index 701d255eb35..db75e7b9709 100644 --- a/justfile +++ b/justfile @@ -46,6 +46,9 @@ unit-tests-cabal-match match: -O0 -v0 \ --test-options '--match="{{match}}"' +unit-tests-local-cluster-match match: + nix shell '.#local-cluster' 'nixpkgs#just' \ + -c just unit-tests-cabal-match {{match}} # run unit tests unit-tests-cabal: just unit-tests-cabal-match "" diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index 55f1a78071f..adc6f844f2f 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -197,21 +197,28 @@ test-suite test , aeson , base , bytestring + , cardano-wallet-application-extras + , cardano-wallet-launcher , cardano-wallet-primitive , cardano-wallet-test-utils , contra-tracer + , filepath , foldl , hspec , hspec-golden , local-cluster , mtl , openapi3 + , process , QuickCheck , time , unliftio , with-utf8 - build-tool-depends: hspec-discover:hspec-discover + build-tool-depends: + , hspec-discover:hspec-discover + , local-cluster:local-cluster + other-modules: Cardano.Wallet.Launch.Cluster.Http.Faucet.APISpec Cardano.Wallet.Launch.Cluster.Http.Faucet.SendFaucetAssetsSpec diff --git a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs index 3d91e5c411b..91c31153497 100644 --- a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs +++ b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Cardano.Wallet.Launch.Cluster.Http.ServiceSpec ( spec ) @@ -5,6 +7,14 @@ where import Prelude +import Cardano.Launcher + ( Command (..) + , ProcessHandles (..) + , withBackendProcess + ) +import Cardano.Wallet.Launch.Cluster.Http.Faucet.Client + ( RunFaucetQ + ) import Cardano.Wallet.Launch.Cluster.Http.Monitor.Client ( MonitorQ (..) , RunMonitorQ (..) @@ -12,19 +22,31 @@ import Cardano.Wallet.Launch.Cluster.Http.Monitor.Client import Cardano.Wallet.Launch.Cluster.Http.Service ( ServiceConfiguration (..) , withService + , withServiceClient ) import Cardano.Wallet.Launch.Cluster.Monitoring.Phase ( History (..) , Phase (..) ) +import Cardano.Wallet.Network.Ports + ( PortNumber + , getRandomPort + ) import Cardano.Wallet.Primitive.NetworkId - ( SNetworkId (SMainnet) + ( NetworkId (..) + , SNetworkId (SMainnet) + , withSNetworkId + ) +import Control.Exception + ( finally ) import Control.Monad - ( unless + ( forM_ + , unless ) import Control.Monad.Cont - ( evalContT + ( ContT (..) + , evalContT ) import Control.Monad.Fix ( fix @@ -40,6 +62,16 @@ import Control.Tracer , nullTracer , traceWith ) +import System.Environment + ( lookupEnv + ) +import System.FilePath + ( () + ) +import System.Process + ( StdStream (..) + , cleanupProcess + ) import Test.Hspec ( Spec , describe @@ -53,6 +85,9 @@ import UnliftIO.Async import UnliftIO.Concurrent ( threadDelay ) +import UnliftIO.Directory + ( createDirectoryIfMissing + ) testService :: MonitorState @@ -61,11 +96,74 @@ testService testService w f = evalContT $ do (tracer, (query, _)) <- - withService SMainnet (error "No connection") - (error "No cluster") nullTracer + withService + SMainnet + (error "No connection") + (error "No cluster") + nullTracer $ ServiceConfiguration Nothing w liftIO $ f tracer query +localClusterCommand + :: FilePath + -- ^ filename to append to the logs dir + -> PortNumber + -- ^ monitoring port + -> IO Command +localClusterCommand name port = do + configsPath <- getClusterConfigsPathFromEnv + mLogsPath <- getClusterLogsFilePathFromEnv + mMinSeverity <- getClusterLogsMinSeverity + pure + $ Command + { cmdName = "local-cluster" + , cmdArgs = + [ "--monitoring-port" + , show port + , "--cluster-configs" + , configsPath + ] + <> case mLogsPath of + Nothing -> [] + Just logsPath -> ["--cluster-logs", logsPath name] + <> case mMinSeverity of + Nothing -> [] + Just minSeverity -> ["--min-severity", show minSeverity] + , cmdSetup = pure () + , cmdInput = NoStream + , cmdOutput = NoStream + } + +getClusterConfigsPathFromEnv :: IO FilePath +getClusterConfigsPathFromEnv = do + lookupEnv "LOCAL_CLUSTER_CONFIGS" >>= \case + Just path -> pure path + Nothing -> error "LOCAL_CLUSTER_CONFIGS not set" + +getClusterLogsFilePathFromEnv :: IO (Maybe FilePath) +getClusterLogsFilePathFromEnv = do + mp <- lookupEnv "CLUSTER_LOGS_DIR_PATH" + forM_ mp $ \dir -> + createDirectoryIfMissing True dir + pure mp + +getClusterLogsMinSeverity :: IO (Maybe String) +getClusterLogsMinSeverity = lookupEnv "CLUSTER_LOGS_MIN_SEVERITY" + +testServiceWithCluster + :: FilePath + -> ((RunMonitorQ IO, RunFaucetQ IO) -> IO ()) + -> IO () +testServiceWithCluster name = runContT $ do + port <- liftIO getRandomPort + command <- liftIO $ localClusterCommand name port + ProcessHandles in' out err kill <- do + ContT $ withBackendProcess nullTracer command + queries <- withSNetworkId (NTestnet 42) + $ \network -> withServiceClient network port nullTracer + ContT $ \k -> do + k queries `finally` cleanupProcess (in', out, err, kill) + spec :: Spec spec = do describe "withService control" $ do @@ -123,3 +221,17 @@ spec = do wait tracer' (History phases, _state) <- query ObserveQ snd <$> phases `shouldBe` [RetrievingFunds] + describe "withService application" $ do + it "can start and stop" $ do + testServiceWithCluster + "can-start-and-stop.log" + $ \(RunQuery query, _) -> do + result <- query ReadyQ + result `shouldBe` False + it "can wait for cluster ready before ending" $ do + testServiceWithCluster + "can-wait-for-cluster-ready-before-ending.log" + $ \(RunQuery query, _) -> do + fix $ \loop -> do + result <- query ReadyQ + unless result $ threadDelay 10000 >> loop From f6e96ad8d6f8064ca8d1e41f4186e3503f066aa5 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 8 May 2024 11:39:57 +0000 Subject: [PATCH 10/11] Add some tracing to the local-cluster exe --- lib/local-cluster/exe/local-cluster.hs | 108 ++++++++++++++----------- lib/local-cluster/local-cluster.cabal | 1 + 2 files changed, 62 insertions(+), 47 deletions(-) diff --git a/lib/local-cluster/exe/local-cluster.hs b/lib/local-cluster/exe/local-cluster.hs index a03c126396e..29b6533db97 100644 --- a/lib/local-cluster/exe/local-cluster.hs +++ b/lib/local-cluster/exe/local-cluster.hs @@ -1,11 +1,6 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE ScopedTypeVariables #-} import Prelude @@ -74,6 +69,9 @@ import Control.Monad.IO.Class import Control.Tracer ( traceWith ) +import Data.Text + ( Text + ) import Main.Utf8 ( withUtf8 ) @@ -92,10 +90,11 @@ import System.IO.Temp.Extra ) import System.Path ( absDir + , absFile , parse , relDir , relFile - , (), absFile + , () ) import UnliftIO.Concurrent ( threadDelay @@ -231,14 +230,6 @@ main = withUtf8 $ do -- Ensure key files have correct permissions for cardano-cli setDefaultFilePermissions - skipCleanup <- SkipCleanup <$> isEnvSet "NO_CLEANUP" - - clusterEra <- Cluster.clusterEraFromEnv - cfgNodeLogging <- - Cluster.logFileConfigFromEnv - $ Just - $ mkRelDirOf - $ Cluster.clusterEraToString clusterEra CommandLineOptions { clusterConfigsDir , clusterDir @@ -250,24 +241,38 @@ main = withUtf8 $ do parseCommandLineOptions evalContT $ do -- Add a tracer for the cluster logs - ToTextTracer tr <- + ToTextTracer tracer <- ContT $ newToTextTracer (toFilePath . absFileOf <$> clusterLogs) minSeverity - -- Create a temporary directory for the cluster - clusterPath <- + let debug :: MonadIO m => Text -> m () + debug = liftIO . traceWith tracer + + debug "Creating temporary directory for the cluster" + clusterPath <- do + skipCleanup <- liftIO $ SkipCleanup <$> isEnvSet "NO_CLEANUP" case clusterDir of Just path -> pure path Nothing -> fmap (DirOf . absDir) $ ContT - $ withSystemTempDir tr "test-cluster" skipCleanup - socketPath <- case nodeToClientSocket of - Just path -> pure path - Nothing -> FileOf . absFile <$> ContT withTempFile - let clusterCfg = + $ withSystemTempDir tracer "test-cluster" skipCleanup + + debug "Creating cluster configuration" + clusterCfg <- do + socketPath <- case nodeToClientSocket of + Just path -> pure path + Nothing -> FileOf . absFile <$> ContT withTempFile + clusterEra <- liftIO Cluster.clusterEraFromEnv + cfgNodeLogging <- + liftIO + $ Cluster.logFileConfigFromEnv + $ Just + $ mkRelDirOf + $ Cluster.clusterEraToString clusterEra + pure Cluster.Config { cfgStakePools = Cluster.defaultPoolConfigs , cfgLastHardFork = clusterEra @@ -275,13 +280,15 @@ main = withUtf8 $ do , cfgClusterDir = clusterPath , cfgClusterConfigs = clusterConfigsDir , cfgTestnetMagic = Cluster.TestnetMagic 42 - , cfgShelleyGenesisMods = [over #sgSlotLength \_ -> 0.2] - , cfgTracer = tr + , cfgShelleyGenesisMods = [over #sgSlotLength $ \_ -> 0.2] + , cfgTracer = tracer , cfgNodeOutputFile = Nothing , cfgRelayNodePath = mkRelDirOf "relay" , cfgClusterLogFile = clusterLogs , cfgNodeToClientSocket = socketPath } + + debug "Starting the monitoring server" (_, phaseTracer) <- withSNetworkId (NTestnet 42) $ \network -> do nodeConn <- liftIO newNodeConnVar @@ -289,16 +296,19 @@ main = withUtf8 $ do network nodeConn clusterCfg - tr + tracer httpService - -- Start the faucet + + debug "Starting the faucet" faucetClientEnv <- ContT withFaucet + + debug "Getting multi assets funds" maryAllegraFunds <- liftIO $ runFaucetM faucetClientEnv $ Faucet.maryAllegraFunds (Coin 10_000_000) shelleyTestnet - -- Start the cluster + debug "Starting the cluster" node <- ContT $ Cluster.withCluster @@ -308,37 +318,41 @@ main = withUtf8 $ do , maryAllegraFunds , massiveWalletFunds = [] } + + debug "Starting the relay node" nodeSocket <- case parse . nodeSocketFile $ Cluster.runningNodeSocketPath node of Left e -> error e Right p -> pure p - -- Start the wallet - let clusterDirPath = absDirOf clusterPath - let walletDir = clusterDirPath relDir "wallet" - liftIO $ createDirectoryIfMissing True $ toFilePath walletDir - let walletProcessConfig = - WC.WalletProcessConfig - { WC.walletDir = DirOf walletDir - , WC.walletNodeApi = NC.NodeApi nodeSocket - , WC.walletDatabase = DirOf $ clusterDirPath relDir "db" - , WC.walletListenHost = Nothing - , WC.walletListenPort = Nothing - , WC.walletByronGenesisForTestnet = - Just - $ FileOf - $ clusterDirPath - relFile "byron-genesis.json" - } - - (_walletInstance, _walletApi) <- + debug "Starting the wallet" + (_walletInstance, _walletApi) <- do + let clusterDirPath = absDirOf clusterPath + walletDir = clusterDirPath relDir "wallet" + liftIO $ createDirectoryIfMissing True $ toFilePath walletDir + let walletProcessConfig = + WC.WalletProcessConfig + { WC.walletDir = DirOf walletDir + , WC.walletNodeApi = NC.NodeApi nodeSocket + , WC.walletDatabase = DirOf $ clusterDirPath relDir "db" + , WC.walletListenHost = Nothing + , WC.walletListenPort = Nothing + , WC.walletByronGenesisForTestnet = + Just + $ FileOf + $ clusterDirPath + relFile "byron-genesis.json" + } ContT $ bracket (WC.start walletProcessConfig) (WC.stop . fst) + + debug "Tracing the ready phase" liftIO $ traceWith phaseTracer $ Cluster $ Just $ RelayNode $ toFilePath nodeSocket - -- Wait forever or ctrl-c + + debug "Wait forever or ctrl-c" threadDelay maxBound diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index adc6f844f2f..953de9566be 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -184,6 +184,7 @@ executable local-cluster , mtl , pathtype , temporary-extra + , text , unliftio , with-utf8 From 6b6be2f9c416cd87d9adde60f05d181bd38541fa Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 7 May 2024 13:17:47 +0000 Subject: [PATCH 11/11] Add test executable to local-cluster --- .buildkite/pipeline.yml | 6 +- flake.nix | 1 + justfile | 10 +++ lib/launcher/src/Cardano/Launcher.hs | 81 +++++++++++++------ lib/launcher/src/Cardano/Launcher/Node.hs | 36 +++++---- lib/launcher/src/Cardano/Launcher/Wallet.hs | 40 +++++---- lib/launcher/src/Cardano/Startup.hs | 1 + lib/launcher/src/Cardano/Startup/POSIX.hs | 24 +++--- lib/launcher/src/Cardano/Startup/Windows.hs | 6 +- .../test/unit/Cardano/LauncherSpec.hs | 7 +- .../Cardano/Wallet/Launch/Cluster/Cluster.hs | 17 +++- lib/local-cluster/local-cluster.cabal | 8 +- .../Wallet/Launch/Cluster/Http/ServiceSpec.hs | 22 ++--- lib/local-cluster/test/unit/test-exe.hs | 13 +++ 14 files changed, 187 insertions(+), 85 deletions(-) create mode 100644 lib/local-cluster/test/unit/test-exe.hs diff --git a/.buildkite/pipeline.yml b/.buildkite/pipeline.yml index cf423b49d7e..4d49ee9496b 100644 --- a/.buildkite/pipeline.yml +++ b/.buildkite/pipeline.yml @@ -58,11 +58,15 @@ steps: - label: Run local-cluster tests key: local-cluster-tests depends_on: linux-nix - command: nix shell .#local-cluster -c cabal test -O0 local-cluster + command: | + mkdir local-cluster-logs + nix shell "nixpkgs#just" -c just test-local-cluster agents: system: ${linux} + artifact_paths: [ "./local-cluster-logs/**" ] env: TMPDIR: "/cache" + CLUSTER_LOGS_DIR_PATH: local-cluster-logs - label: "Babbage integration tests (linux)" key: linux-tests-integration-babbage diff --git a/flake.nix b/flake.nix index b8303b2ab9d..c5cbd829016 100644 --- a/flake.nix +++ b/flake.nix @@ -239,6 +239,7 @@ inherit (project.hsPkgs.cardano-wallet.components.exes) mock-token-metadata-server; inherit (project.hsPkgs.local-cluster.components.exes) local-cluster; inherit (project.hsPkgs.cardano-wallet-integration.components.exes) integration-exe; + inherit (project.hsPkgs.local-cluster.components.exes) test-local-cluster-exe; # Adrestia tool belt inherit (project.hsPkgs.bech32.components.exes) bech32; diff --git a/justfile b/justfile index db75e7b9709..1712ca288ff 100644 --- a/justfile +++ b/justfile @@ -141,3 +141,13 @@ conway-integration-tests: latency-bench: cabal run -O2 -v0 cardano-wallet-benchmarks:latency -- \ --cluster-configs lib/local-cluster/test/data/cluster-configs + +test-local-cluster: + LOCAL_CLUSTER_CONFIGS=lib/local-cluster/test/data/cluster-configs \ + nix shell \ + '.#local-cluster' \ + '.#test-local-cluster-exe' \ + '.#cardano-cli' \ + '.#cardano-node' \ + '.#cardano-wallet' \ + -c test-local-cluster-exe diff --git a/lib/launcher/src/Cardano/Launcher.hs b/lib/launcher/src/Cardano/Launcher.hs index e73ee5334b1..863c341c20d 100644 --- a/lib/launcher/src/Cardano/Launcher.hs +++ b/lib/launcher/src/Cardano/Launcher.hs @@ -21,6 +21,8 @@ module Cardano.Launcher , ProcessHasExited(..) , withBackendProcess , withBackendCreateProcess + , IfToSendSigINT (..) + , TimeoutInSecs (..) -- * Logging , LauncherLog(..) @@ -36,7 +38,8 @@ import Cardano.BM.Data.Tracer , HasSeverityAnnotation (..) ) import Cardano.Startup - ( killProcess + ( interruptProcess + , killProcess ) import Control.Monad ( join @@ -191,6 +194,14 @@ data ProcessHasExited instance Exception ProcessHasExited +-- | Whether to send a SIGINT to the process before cleanup +data IfToSendSigINT = SendSigINT | DoNotSendSigINT + +-- | Timeout in seconds to wait before killing the process, after termination +-- Do not use NoTimeout if you are not sure the process will terminate with +-- SIGTERM / SIGINT +data TimeoutInSecs = NoTimeout | TimeoutInSecs Int + data ProcessHandles = ProcessHandles { inputHandle :: Maybe Handle , outputHandle :: Maybe Handle @@ -209,13 +220,23 @@ withBackendProcess -- ^ Logging -> Command -- ^ 'Command' description + -> TimeoutInSecs + -- ^ Seconds to wait before killing the process, after termination + -> IfToSendSigINT + -- ^ Whether to send a sigINT to the process before clenup -> (ProcessHandles -> m a) -- ^ Action to execute while process is running. -> m a -withBackendProcess tr (Command name args before std_in std_out) action = - liftIO before >> withBackendCreateProcess tr process action - where - process = (proc name args) { std_in, std_out, std_err = std_out } +withBackendProcess + tr + (Command name args before std_in std_out) + mTimeoutSecs + ifToSendSigINT + action = do + liftIO before + withBackendCreateProcess tr process mTimeoutSecs ifToSendSigINT action + where + process = (proc name args){std_in, std_out, std_err = std_out} -- | A variant of 'withBackendProcess' which accepts a general 'CreateProcess' -- object. This version also has nicer async properties than @@ -237,27 +258,35 @@ withBackendProcess tr (Command name args before std_in std_out) action = -- 'System.Process.Typed.withProcessWait' (except for wait timeout). The -- launcher code should be converted to use @typed-process@. withBackendCreateProcess - :: forall m a. (MonadUnliftIO m) + :: forall m a + . MonadUnliftIO m => Tracer m LauncherLog -- ^ Logging -> CreateProcess -- ^ 'Command' description + -> TimeoutInSecs + -- ^ Seconds to wait before killing the process, after termination + -> IfToSendSigINT + -- ^ Whether to send a sigINT to the process before clenup -> (ProcessHandles -> m a) -- ^ Action to execute while process is running. -> m a -withBackendCreateProcess tr process action = do +withBackendCreateProcess tr process mTimeoutSecs ifToSendSigINT action = do traceWith tr $ MsgLauncherStart name args exitVar <- newEmptyMVar - res <- fmap join $ tryJust spawnPredicate $ bracket - (createProcess process) - (cleanupProcessAndWait (readMVar exitVar)) $ - \(mstdin, mstdout, mstderr, ph) -> do - pid <- maybe "-" (T.pack . show) <$> liftIO (getPid ph) - let tr' = contramap (WithProcessInfo name pid) tr - let tr'' = contramap MsgLauncherWait tr' - traceWith tr' MsgLauncherStarted - interruptibleWaitForProcess tr'' ph (putMVar exitVar) - race (ProcessHasExited name <$> readMVar exitVar) $ bracket_ + res <- fmap join + $ tryJust spawnPredicate + $ bracket + (createProcess process) + (cleanupProcessAndWait (readMVar exitVar)) + $ \(mstdin, mstdout, mstderr, ph) -> do + pid <- maybe "-" (T.pack . show) <$> liftIO (getPid ph) + let tr' = contramap (WithProcessInfo name pid) tr + let tr'' = contramap MsgLauncherWait tr' + traceWith tr' MsgLauncherStarted + interruptibleWaitForProcess tr'' ph (putMVar exitVar) + race (ProcessHasExited name <$> readMVar exitVar) + $ bracket_ (traceWith tr' MsgLauncherAction) (traceWith tr' MsgLauncherActionDone) (action $ ProcessHandles mstdin mstdout mstderr ph) @@ -279,16 +308,22 @@ withBackendCreateProcess tr process action = do -- doesn't exit after timeout, kill it, to avoid blocking indefinitely. cleanupProcessAndWait getExitStatus ps@(_, _, _, ph) = do traceWith tr MsgLauncherCleanup + -- we also send a sigINT to the process to make sure it terminates + case ifToSendSigINT of + SendSigINT -> liftIO $ getPid ph >>= mapM_ interruptProcess + DoNotSendSigINT -> pure () liftIO $ cleanupProcess ps - let timeoutSecs = 5 -- Async exceptions are currently masked because this is running in a -- bracket cleanup handler. We fork a thread and unmask so that the -- timeout can be cancelled. - tid <- forkIOWithUnmask $ \unmask -> unmask $ do - threadDelay (timeoutSecs * 1000 * 1000) - traceWith tr (MsgLauncherCleanupTimedOut timeoutSecs) - liftIO (getPid ph >>= mapM_ killProcess) - void getExitStatus `finally` killThread tid + void $ case mTimeoutSecs of + NoTimeout -> getExitStatus + TimeoutInSecs timeoutSecs -> do + tid <- forkIOWithUnmask $ \unmask -> unmask $ do + threadDelay (timeoutSecs * 1000 * 1000) + traceWith tr (MsgLauncherCleanupTimedOut timeoutSecs) + liftIO (getPid ph >>= mapM_ killProcess) + getExitStatus `finally` killThread tid traceWith tr MsgLauncherCleanupFinished -- Wraps 'waitForProcess' in another thread. This works around the unwanted diff --git a/lib/launcher/src/Cardano/Launcher/Node.hs b/lib/launcher/src/Cardano/Launcher/Node.hs index 18facd23171..bccae55c8cb 100644 --- a/lib/launcher/src/Cardano/Launcher/Node.hs +++ b/lib/launcher/src/Cardano/Launcher/Node.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-} + -- | -- Copyright: © 2018-2020 IOHK -- License: Apache-2.0 -- -- Provides a function to launch @cardano-node@. - module Cardano.Launcher.Node ( -- * Startup withCardanoNode @@ -16,21 +16,23 @@ module Cardano.Launcher.Node , maybeFromMaybeK , NodePort (..) - -- * cardano-node Snockets + -- * cardano-node Snockets , CardanoNodeConn , cardanoNodeConn , nodeSocketFile , isWindows - -- * Helpers + -- * Helpers , nodeSocketPath ) where import Prelude import Cardano.Launcher - ( LauncherLog + ( IfToSendSigINT (..) + , LauncherLog , StdStream (..) + , TimeoutInSecs (..) , withBackendCreateProcess ) import Control.Tracer @@ -90,19 +92,22 @@ nodeSocketFile (CardanoNodeConn name) = name -- 'isWindows') is valid. cardanoNodeConn :: FilePath -> Either String CardanoNodeConn cardanoNodeConn name - | isWindows = if isValidWindowsPipeName name - then Right $ CardanoNodeConn name - else Left "Invalid pipe name." - | otherwise = if isValid name - then Right $ CardanoNodeConn name - else Left "Invalid file path." + | isWindows = + if isValidWindowsPipeName name + then Right $ CardanoNodeConn name + else Left "Invalid pipe name." + | otherwise = + if isValid name + then Right $ CardanoNodeConn name + else Left "Invalid file path." isWindows :: Bool isWindows = os == "mingw32" isValidWindowsPipeName :: FilePath -> Bool -isValidWindowsPipeName name = slashPipe `isPrefixOf` name - && isValid (drop (length slashPipe) name) +isValidWindowsPipeName name = + slashPipe `isPrefixOf` name + && isValid (drop (length slashPipe) name) where slashPipe = "\\\\.\\pipe\\" @@ -112,7 +117,7 @@ instance ToText CardanoNodeConn where instance FromText CardanoNodeConn where fromText = first TextDecodingError . cardanoNodeConn . T.unpack -newtype NodePort = NodePort { unNodePort :: Int } +newtype NodePort = NodePort {unNodePort :: Int} deriving (Show, Eq) -- | A subset of the @cardano-node@ CLI parameters, used for starting the @@ -150,7 +155,7 @@ withCardanoNode tr cfg action = do let socketPath = nodeSocketPathFile cfg let run output = do cp <- cardanoNodeProcess cfg output - withBackendCreateProcess tr cp + withBackendCreateProcess tr cp (TimeoutInSecs 4) SendSigINT $ \_ -> action $ fmap CardanoNodeConn socketPath case nodeOutputFile cfg of Nothing -> run Inherit @@ -185,7 +190,8 @@ cardanoNodeProcess cfg output = do , "--database-path" , nodeDatabaseDir cfg ] - <> maybe [] + <> maybe + [] (\p -> ["--socket-path", p]) (maybeFromMaybeK $ nodeSocketPathFile cfg) <> opt "--port" (show . unNodePort <$> nodePort cfg) diff --git a/lib/launcher/src/Cardano/Launcher/Wallet.hs b/lib/launcher/src/Cardano/Launcher/Wallet.hs index f0228f9619e..c6317e08a73 100644 --- a/lib/launcher/src/Cardano/Launcher/Wallet.hs +++ b/lib/launcher/src/Cardano/Launcher/Wallet.hs @@ -19,7 +19,9 @@ module Cardano.Launcher.Wallet import Prelude import Cardano.Launcher - ( LauncherLog + ( IfToSendSigINT (DoNotSendSigINT) + , LauncherLog + , TimeoutInSecs (..) , withBackendCreateProcess ) import Cardano.Launcher.Node @@ -92,23 +94,27 @@ withCardanoWallet -- ^ Callback function with a socket filename and genesis params -> IO a withCardanoWallet tr node cfg@CardanoWalletConfig{..} action = - withBackendCreateProcess tr (cardanoWallet cfg node) + withBackendCreateProcess + tr + (cardanoWallet cfg node) + (TimeoutInSecs 4) + DoNotSendSigINT $ \_ -> action $ CardanoWalletConn walletPort cardanoWallet :: CardanoWalletConfig -> CardanoNodeConn -> CreateProcess cardanoWallet CardanoWalletConfig{..} node = - - let cp = proc (fromMaybe "cardano-wallet" executable) - $ [ "serve" - , "--node-socket" - , nodeSocketFile node - , "--database" - , walletDatabaseDir - , "--port" - , show walletPort - ] - <> case walletNetwork of - Mainnet -> ["--mainnet"] - Testnet path -> ["--testnet", path] - <> extraArgs - in cp { cwd = workingDir } + let cp = + proc (fromMaybe "cardano-wallet" executable) + $ [ "serve" + , "--node-socket" + , nodeSocketFile node + , "--database" + , walletDatabaseDir + , "--port" + , show walletPort + ] + <> case walletNetwork of + Mainnet -> ["--mainnet"] + Testnet path -> ["--testnet", path] + <> extraArgs + in cp{cwd = workingDir} diff --git a/lib/launcher/src/Cardano/Startup.hs b/lib/launcher/src/Cardano/Startup.hs index 5fa49df1832..f7ca6bd922d 100644 --- a/lib/launcher/src/Cardano/Startup.hs +++ b/lib/launcher/src/Cardano/Startup.hs @@ -16,6 +16,7 @@ module Cardano.Startup , installSignalHandlers , installSignalHandlersNoLogging , killProcess + , interruptProcess -- * File permissions , setDefaultFilePermissions diff --git a/lib/launcher/src/Cardano/Startup/POSIX.hs b/lib/launcher/src/Cardano/Startup/POSIX.hs index 3a99d8c39eb..40feddbc364 100644 --- a/lib/launcher/src/Cardano/Startup/POSIX.hs +++ b/lib/launcher/src/Cardano/Startup/POSIX.hs @@ -2,13 +2,12 @@ -- Copyright: © 2018-2020 IOHK -- License: Apache-2.0 -- Portability: POSIX --- - module Cardano.Startup.POSIX ( installSignalHandlers , setDefaultFilePermissions , restrictFileMode , killProcess + , interruptProcess ) where import Prelude @@ -31,6 +30,7 @@ import System.Posix.Signals , installHandler , keyboardSignal , raiseSignal + , sigINT , sigKILL , signalProcess , softwareTermination @@ -42,18 +42,20 @@ import System.Process -- | Convert any SIGTERM received to SIGINT, for which the runtime system has -- handlers that will correctly clean up sub-processes. installSignalHandlers :: IO () -> IO () -installSignalHandlers notify = void $ - installHandler softwareTermination termHandler Nothing - where - termHandler = CatchOnce $ do - notify - raiseSignal keyboardSignal +installSignalHandlers notify = + void + $ installHandler softwareTermination termHandler Nothing + where + termHandler = CatchOnce $ do + notify + raiseSignal keyboardSignal -- | Restricts the process umask so that any files created are only readable by -- their owner. setDefaultFilePermissions :: IO () setDefaultFilePermissions = void $ setFileCreationMask mask - where mask = groupModes .|. otherModes + where + mask = groupModes .|. otherModes -- | Changes permissions of an existing file so that only the owner can read -- them. @@ -64,3 +66,7 @@ restrictFileMode f = setFileMode f ownerReadMode -- terminate the process did not work. killProcess :: Pid -> IO () killProcess = signalProcess sigKILL + +-- | Interrupt a process with sigINT +interruptProcess :: Pid -> IO () +interruptProcess = signalProcess sigINT diff --git a/lib/launcher/src/Cardano/Startup/Windows.hs b/lib/launcher/src/Cardano/Startup/Windows.hs index b43ddf29ed7..b79b19734c6 100644 --- a/lib/launcher/src/Cardano/Startup/Windows.hs +++ b/lib/launcher/src/Cardano/Startup/Windows.hs @@ -2,13 +2,12 @@ -- Copyright: © 2018-2020 IOHK -- License: Apache-2.0 -- Portability: Windows --- - module Cardano.Startup.Windows ( installSignalHandlers , setDefaultFilePermissions , restrictFileMode , killProcess + , interruptProcess ) where import Prelude @@ -33,3 +32,6 @@ restrictFileMode _ = pure () -- 'terminateProcess' is to kill, so this isn't needed. killProcess :: Pid -> IO () killProcess _ = pure () + +interruptProcess :: Pid -> IO () +interruptProcess _ = pure () diff --git a/lib/launcher/test/unit/Cardano/LauncherSpec.hs b/lib/launcher/test/unit/Cardano/LauncherSpec.hs index 2e58f1e9d9c..f741d71775a 100644 --- a/lib/launcher/test/unit/Cardano/LauncherSpec.hs +++ b/lib/launcher/test/unit/Cardano/LauncherSpec.hs @@ -37,10 +37,12 @@ import Cardano.BM.Trace ) import Cardano.Launcher ( Command (..) + , IfToSendSigINT (DoNotSendSigINT) , LauncherLog , ProcessHandles (..) , ProcessHasExited (..) , StdStream (..) + , TimeoutInSecs (TimeoutInSecs) , withBackendProcess ) import Control.Monad @@ -208,6 +210,7 @@ spec = beforeAll setupMockCommands $ do pendingOnWine "SYSTEM32 commands not available under wine" mvar <- newEmptyMVar let backend = withBackendProcess tr foreverCommand + (TimeoutInSecs 5) DoNotSendSigINT $ \(ProcessHandles _ _ _ ph) -> do putMVar mvar ph forever $ threadDelay maxBound @@ -224,6 +227,7 @@ spec = beforeAll setupMockCommands $ do skipOnWindows "Not applicable" mvar <- newEmptyMVar let backend = withBackendProcess tr unkillableCommand + (TimeoutInSecs 5) DoNotSendSigINT $ \(ProcessHandles _ _ _ ph) -> do putMVar mvar ph forever $ threadDelay maxBound @@ -278,7 +282,8 @@ launch tr cmds = do waitForOthers (ProcessHandles _ _ _ ph) = do modifyMVar_ phsVar (pure . (ph:)) forever $ threadDelay maxBound - start = async . try . flip (withBackendProcess tr) waitForOthers + start c = async . try + $ withBackendProcess tr c (TimeoutInSecs 5) DoNotSendSigINT waitForOthers mapM start cmds >>= waitAnyCancel >>= \case (_, Left e) -> do diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs index 3ed40226cc6..fc76415f144 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs @@ -121,6 +121,9 @@ import Data.List import Data.List.NonEmpty ( NonEmpty ((:|)) ) +import Data.Text + ( Text + ) import System.Exit ( ExitCode (..) ) @@ -182,6 +185,8 @@ withCluster withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config $ bracketTracer' "withCluster" $ do + let debug :: MonadIO m => Text -> m () + debug x = liftIO $ traceWith cfgTracer $ MsgDebug x liftIO resetGlobals let clusterDir = absDirOf cfgClusterDir @@ -244,11 +249,14 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config case NE.nonEmpty otherPools of Nothing -> liftIO $ onClusterStart relayNode Just others -> do - contT_ - $ launchPools + ContT $ \k -> do + debug "Starting pools" + r <- launchPools others genesisFiles - poolPorts + poolPorts $ k () + debug "Pools are down" + pure r liftIO $ onClusterStart relayNode where contT_ :: Monad m => (m a -> m a) -> ContT a m () @@ -342,9 +350,10 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config readChan doneGroup mapM_ link asyncs let cancelAll = do - traceWith cfgTracer $ MsgDebug "stopping all stake pools" + traceWith cfgTracer $ MsgDebug "Stopping all stake pools" replicateM_ poolCount (writeChan doneGroup ()) mapM_ wait asyncs + traceWith cfgTracer $ MsgDebug "All stake pools are down" traceClusterLog $ MsgRegisteringStakePools poolCount group <- waitAll diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index 953de9566be..c8e7fd3b173 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -188,10 +188,8 @@ executable local-cluster , unliftio , with-utf8 -test-suite test +common test-common import: language - type: exitcode-stdio-1.0 - main-is: test.hs ghc-options: -threaded -rtsopts hs-source-dirs: test/unit build-depends: @@ -231,3 +229,7 @@ test-suite test Paths_local_cluster Spec SpecHook + +executable test-local-cluster-exe + import: test-common + main-is: test-exe.hs diff --git a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs index 91c31153497..eb2201020a0 100644 --- a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs +++ b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs @@ -9,7 +9,8 @@ import Prelude import Cardano.Launcher ( Command (..) - , ProcessHandles (..) + , IfToSendSigINT (..) + , TimeoutInSecs (..) , withBackendProcess ) import Cardano.Wallet.Launch.Cluster.Http.Faucet.Client @@ -37,12 +38,10 @@ import Cardano.Wallet.Primitive.NetworkId , SNetworkId (SMainnet) , withSNetworkId ) -import Control.Exception - ( finally - ) import Control.Monad ( forM_ , unless + , void ) import Control.Monad.Cont ( ContT (..) @@ -70,7 +69,6 @@ import System.FilePath ) import System.Process ( StdStream (..) - , cleanupProcess ) import Test.Hspec ( Spec @@ -154,15 +152,19 @@ testServiceWithCluster :: FilePath -> ((RunMonitorQ IO, RunFaucetQ IO) -> IO ()) -> IO () -testServiceWithCluster name = runContT $ do +testServiceWithCluster name action = evalContT $ do port <- liftIO getRandomPort command <- liftIO $ localClusterCommand name port - ProcessHandles in' out err kill <- do - ContT $ withBackendProcess nullTracer command + void + $ ContT + $ withBackendProcess + nullTracer + command + NoTimeout + DoNotSendSigINT queries <- withSNetworkId (NTestnet 42) $ \network -> withServiceClient network port nullTracer - ContT $ \k -> do - k queries `finally` cleanupProcess (in', out, err, kill) + liftIO $ action queries spec :: Spec spec = do diff --git a/lib/local-cluster/test/unit/test-exe.hs b/lib/local-cluster/test/unit/test-exe.hs new file mode 100644 index 00000000000..379da0ad22b --- /dev/null +++ b/lib/local-cluster/test/unit/test-exe.hs @@ -0,0 +1,13 @@ +import Prelude + +import Main.Utf8 + ( withUtf8 + ) +import Test.Hspec.Extra + ( hspecMain + ) + +import qualified Spec + +main :: IO () +main = withUtf8 $ hspecMain Spec.spec