diff --git a/.buildkite/pipeline.yml b/.buildkite/pipeline.yml index eabf977bcc3..4d49ee9496b 100644 --- a/.buildkite/pipeline.yml +++ b/.buildkite/pipeline.yml @@ -55,6 +55,19 @@ steps: env: TMPDIR: "/cache" + - label: Run local-cluster tests + key: local-cluster-tests + depends_on: linux-nix + 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 depends_on: linux-nix 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 701d255eb35..1712ca288ff 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 "" @@ -138,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/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 diff --git a/lib/launcher/src/Cardano/Launcher.hs b/lib/launcher/src/Cardano/Launcher.hs index eb718198e9e..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 @@ -65,6 +68,9 @@ import Data.Text import Data.Text.Class ( ToText (..) ) +import Data.Text.Lazy.Builder + ( toLazyText + ) import Fmt ( Buildable (..) , Builder @@ -124,6 +130,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 +156,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 @@ -187,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 @@ -205,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 @@ -233,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) @@ -275,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/exe/local-cluster.hs b/lib/local-cluster/exe/local-cluster.hs index fbd24414881..29b6533db97 100644 --- a/lib/local-cluster/exe/local-cluster.hs +++ b/lib/local-cluster/exe/local-cluster.hs @@ -1,19 +1,15 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE ScopedTypeVariables #-} import Prelude import Cardano.Address.Style.Shelley ( shelleyTestnet ) -import Cardano.BM.Extra - ( stdoutTextTracer +import Cardano.BM.ToTextTracer + ( ToTextTracer (..) + , newToTextTracer ) import Cardano.Launcher.Node ( nodeSocketFile @@ -40,6 +36,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 +66,12 @@ import Control.Monad.Cont import Control.Monad.IO.Class ( MonadIO (..) ) +import Control.Tracer + ( traceWith + ) +import Data.Text + ( Text + ) import Main.Utf8 ( withUtf8 ) @@ -65,12 +81,16 @@ import System.Directory import System.Environment.Extended ( isEnvSet ) +import System.IO.Extra + ( withTempFile + ) import System.IO.Temp.Extra ( SkipCleanup (..) , withSystemTempDir ) import System.Path ( absDir + , absFile , parse , relDir , relFile @@ -210,37 +230,49 @@ main = withUtf8 $ do -- Ensure key files have correct permissions for cardano-cli setDefaultFilePermissions - skipCleanup <- SkipCleanup <$> isEnvSet "NO_CLEANUP" - let tr = stdoutTextTracer - clusterEra <- Cluster.clusterEraFromEnv - cfgNodeLogging <- - Cluster.logFileConfigFromEnv - $ Just - $ mkRelDirOf - $ Cluster.clusterEraToString clusterEra CommandLineOptions { clusterConfigsDir , clusterDir , clusterLogs , nodeToClientSocket + , httpService + , minSeverity } <- parseCommandLineOptions evalContT $ do - -- Create a temporary directory for the cluster - clusterPath <- + -- Add a tracer for the cluster logs + ToTextTracer tracer <- + ContT + $ newToTextTracer + (toFilePath . absFileOf <$> clusterLogs) + minSeverity + + 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 - -- Start the faucet - faucetClientEnv <- ContT withFaucet - maryAllegraFunds <- - liftIO - $ runFaucetM faucetClientEnv - $ Faucet.maryAllegraFunds (Coin 10_000_000) shelleyTestnet - -- Start the cluster - let clusterCfg = + fmap (DirOf . absDir) + $ ContT + $ 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 @@ -248,13 +280,35 @@ main = withUtf8 $ do , cfgClusterDir = clusterPath , cfgClusterConfigs = clusterConfigsDir , cfgTestnetMagic = Cluster.TestnetMagic 42 - , cfgShelleyGenesisMods = [over #sgSlotLength \_ -> 0.2] - , cfgTracer = stdoutTextTracer + , cfgShelleyGenesisMods = [over #sgSlotLength $ \_ -> 0.2] + , cfgTracer = tracer , cfgNodeOutputFile = Nothing , cfgRelayNodePath = mkRelDirOf "relay" , cfgClusterLogFile = clusterLogs - , cfgNodeToClientSocket = nodeToClientSocket + , cfgNodeToClientSocket = socketPath } + + debug "Starting the monitoring server" + (_, phaseTracer) <- withSNetworkId (NTestnet 42) + $ \network -> do + nodeConn <- liftIO newNodeConnVar + withServiceServer + network + nodeConn + clusterCfg + tracer + httpService + + debug "Starting the faucet" + faucetClientEnv <- ContT withFaucet + + debug "Getting multi assets funds" + maryAllegraFunds <- + liftIO + $ runFaucetM faucetClientEnv + $ Faucet.maryAllegraFunds (Coin 10_000_000) shelleyTestnet + + debug "Starting the cluster" node <- ContT $ Cluster.withCluster @@ -264,30 +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) - -- Wait forever or ctrl-c + + debug "Tracing the ready phase" + liftIO + $ traceWith phaseTracer + $ Cluster + $ Just + $ RelayNode + $ toFilePath nodeSocket + + debug "Wait forever or ctrl-c" threadDelay maxBound 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/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/CommandLine.hs index a151f701838..2ea4e9e1d8b 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 (..) @@ -10,20 +11,40 @@ where import Prelude +import Cardano.BM.Data.Severity + ( Severity + ) import Cardano.Wallet.Launch.Cluster.FileOf ( Absolutizer (..) , DirOf (..) , 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 @@ -33,11 +54,15 @@ 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") - , nodeToClientSocket :: FileOf "node-to-client-socket" + , minSeverity :: Maybe Severity + , nodeToClientSocket :: Maybe (FileOf "node-to-client-socket") + , httpService :: ServiceConfiguration } deriving stock (Show) @@ -50,19 +75,98 @@ parseCommandLineOptions = do <$> clusterConfigsDirParser absolutizer <*> clusterDirParser absolutizer <*> clusterLogsParser absolutizer + <*> minSeverityParser <*> nodeToClientSocketParser absolutizer + <*> monitoringParser <**> helper ) (progDesc "Local Cluster for testing") -nodeToClientSocketParser :: Absolutizer -> Parser (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" +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 + <$> 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 (Maybe (FileOf "node-to-client-socket")) +nodeToClientSocketParser (Absolutizer absOf) = + 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/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 diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index ad07c202e26..c8e7fd3b173 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -175,41 +175,49 @@ executable local-cluster , cardano-wallet-application-extras , cardano-wallet-launcher , cardano-wallet-primitive + , contra-tracer , directory + , extra , iohk-monitoring-extra , lens , local-cluster , mtl , pathtype , temporary-extra + , text , 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: , 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 @@ -221,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 3d91e5c411b..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 @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Cardano.Wallet.Launch.Cluster.Http.ServiceSpec ( spec ) @@ -5,6 +7,15 @@ where import Prelude +import Cardano.Launcher + ( Command (..) + , IfToSendSigINT (..) + , TimeoutInSecs (..) + , withBackendProcess + ) +import Cardano.Wallet.Launch.Cluster.Http.Faucet.Client + ( RunFaucetQ + ) import Cardano.Wallet.Launch.Cluster.Http.Monitor.Client ( MonitorQ (..) , RunMonitorQ (..) @@ -12,19 +23,29 @@ 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.Monad - ( unless + ( forM_ + , unless + , void ) import Control.Monad.Cont - ( evalContT + ( ContT (..) + , evalContT ) import Control.Monad.Fix ( fix @@ -40,6 +61,15 @@ import Control.Tracer , nullTracer , traceWith ) +import System.Environment + ( lookupEnv + ) +import System.FilePath + ( () + ) +import System.Process + ( StdStream (..) + ) import Test.Hspec ( Spec , describe @@ -53,6 +83,9 @@ import UnliftIO.Async import UnliftIO.Concurrent ( threadDelay ) +import UnliftIO.Directory + ( createDirectoryIfMissing + ) testService :: MonitorState @@ -61,11 +94,78 @@ 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 action = evalContT $ do + port <- liftIO getRandomPort + command <- liftIO $ localClusterCommand name port + void + $ ContT + $ withBackendProcess + nullTracer + command + NoTimeout + DoNotSendSigINT + queries <- withSNetworkId (NTestnet 42) + $ \network -> withServiceClient network port nullTracer + liftIO $ action queries + spec :: Spec spec = do describe "withService control" $ do @@ -123,3 +223,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 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