From fb1290ab351d3f542c6b4d76ba004203a8307325 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Sun, 10 Jan 2021 20:12:43 +0800 Subject: [PATCH] Set CARDANO_NODE_SOCKET_PATH only in child processes Using the global environment variable CARDANO_NODE_SOCKET_PATH caused problems when setting up multiple test clusters in one process. So now the socket path is passed only to the cardano-cli commands which need it. The bulk of this change is using the CardanoNodeConn newtype everywhere, so that FilePath arguments don't get mixed up. Then, the `cli` function calls needed to be modified to set CARDANO_NODE_SOCKET_PATH in the child process environment, if needed. Since I was changing them all anyway, I thought we may as well use typed-process, which is better and safer than process. --- .../src/Cardano/Wallet/BenchShared.hs | 31 +- lib/launcher/src/Cardano/Launcher/Node.hs | 56 +++- lib/shelley/bench/Latency.hs | 16 +- lib/shelley/bench/Restore.hs | 11 +- lib/shelley/cardano-wallet.cabal | 1 + lib/shelley/exe/cardano-wallet.hs | 8 +- lib/shelley/exe/shelley-test-cluster.hs | 12 +- lib/shelley/src/Cardano/Wallet/Shelley.hs | 17 +- .../src/Cardano/Wallet/Shelley/Launch.hs | 272 ++++++++++-------- .../src/Cardano/Wallet/Shelley/Network.hs | 28 +- lib/shelley/test/integration/Main.hs | 95 +++--- .../Cardano/Wallet/Shelley/NetworkSpec.hs | 9 +- 12 files changed, 327 insertions(+), 229 deletions(-) diff --git a/lib/core-integration/src/Cardano/Wallet/BenchShared.hs b/lib/core-integration/src/Cardano/Wallet/BenchShared.hs index 0f23049f2fa..4df94773f7c 100644 --- a/lib/core-integration/src/Cardano/Wallet/BenchShared.hs +++ b/lib/core-integration/src/Cardano/Wallet/BenchShared.hs @@ -36,8 +36,9 @@ import Cardano.BM.Trace ( Trace, nullTracer ) import Cardano.Launcher.Node ( CardanoNodeConfig (..) - , CardanoNodeConn (..) + , CardanoNodeConn , NodePort (..) + , cardanoNodeConn , withCardanoNode ) import Cardano.Startup @@ -68,12 +69,14 @@ import Options.Applicative ( HasValue , Mod , Parser + , eitherReader , execParser , help , helper , info , long , metavar + , option , optional , short , showDefaultWith @@ -88,6 +91,8 @@ import System.Directory ( createDirectoryIfMissing ) import System.Environment ( lookupEnv ) +import System.Exit + ( die ) import System.FilePath ( () ) import System.IO @@ -109,7 +114,7 @@ import qualified Cardano.BM.Data.BackendKind as CM execBenchWithNode :: (RestoreBenchArgs -> cfg) -- ^ Get backend-specific network configuration from args - -> (Trace IO Text -> cfg -> FilePath -> IO ()) + -> (Trace IO Text -> cfg -> CardanoNodeConn -> IO ()) -- ^ Action to run -> IO () execBenchWithNode networkConfig action = do @@ -123,12 +128,12 @@ execBenchWithNode networkConfig action = do installSignalHandlers (return ()) case argUseAlreadyRunningNodeSocketPath args of - Just socket -> - action tr (networkConfig args) socket + Just conn -> + action tr (networkConfig args) conn Nothing -> do void $ withNetworkConfiguration args $ \nodeConfig -> - withCardanoNode (trMessageText tr) nodeConfig $ \cp -> - action tr (networkConfig args) (nodeSocketFile cp) + withCardanoNode (trMessageText tr) nodeConfig $ + action tr (networkConfig args) withNetworkConfiguration :: RestoreBenchArgs -> (CardanoNodeConfig -> IO a) -> IO a withNetworkConfiguration args action = do @@ -166,7 +171,7 @@ data RestoreBenchArgs = RestoreBenchArgs { argNetworkName :: String , argConfigsDir :: FilePath , argNodeDatabaseDir :: Maybe FilePath - , argUseAlreadyRunningNodeSocketPath :: Maybe FilePath + , argUseAlreadyRunningNodeSocketPath :: Maybe CardanoNodeConn , argQuiet :: Bool } deriving (Show, Eq) @@ -174,8 +179,9 @@ restoreBenchArgsParser :: Maybe String -> Maybe FilePath -> Maybe FilePath + -> Maybe CardanoNodeConn -> Parser RestoreBenchArgs -restoreBenchArgsParser envNetwork envConfigsDir envNodeDatabaseDir = RestoreBenchArgs +restoreBenchArgsParser envNetwork envConfigsDir envNodeDatabaseDir envNodeSocket = RestoreBenchArgs <$> strArgument ( metavar "NETWORK" <> envDefault "NETWORK" envNetwork @@ -194,12 +200,12 @@ restoreBenchArgsParser envNetwork envConfigsDir envNodeDatabaseDir = RestoreBenc <> envDefault "NODE_DB" envNodeDatabaseDir <> help "Directory to put cardano-node state. Defaults to $NODE_DB, \ \falls back to temporary directory")) - <*> optional (strOption + <*> optional (option (eitherReader cardanoNodeConn) ( long "running-node" <> metavar "SOCKET" - <> envDefault "CARDANO_NODE_SOCKET" envNodeDatabaseDir + <> envDefault "CARDANO_NODE_SOCKET_PATH" envNodeSocket <> help "Path to the socket of an already running cardano-node. \ - \Also set by $CARDANO_NODE_SOCKET. If not set, cardano-node \ + \Also set by $CARDANO_NODE_SOCKET_PATH. If not set, cardano-node \ \will automatically be started.")) <*> switch ( long ("quiet") @@ -216,11 +222,14 @@ getRestoreBenchArgsParser = restoreBenchArgsParser <$> lookupEnv' "NETWORK" <*> lookupEnv' "CARDANO_NODE_CONFIGS" <*> lookupEnv' "NODE_DB" + <*> parseEnv cardanoNodeConn "CARDANO_NODE_SOCKET" where lookupEnv' k = lookupEnv k <&> \case Just "" -> Nothing Just v -> Just v Nothing -> Nothing + parseEnv p k = lookupEnv' k >>= traverse (either exit pure . p) + where exit err = die (k ++ ": " ++ err) getRestoreBenchArgs :: IO RestoreBenchArgs getRestoreBenchArgs = do diff --git a/lib/launcher/src/Cardano/Launcher/Node.hs b/lib/launcher/src/Cardano/Launcher/Node.hs index 638d44c7145..b4f28cdd6a3 100644 --- a/lib/launcher/src/Cardano/Launcher/Node.hs +++ b/lib/launcher/src/Cardano/Launcher/Node.hs @@ -6,11 +6,17 @@ -- Provides a function to launch @cardano-node@. module Cardano.Launcher.Node - ( withCardanoNode + ( -- * Startup + withCardanoNode , CardanoNodeConfig (..) , defaultCardanoNodeConfig - , CardanoNodeConn (..) , NodePort (..) + + -- * cardano-node Snockets + , CardanoNodeConn + , cardanoNodeConn + , nodeSocketFile + , isWindows ) where import Prelude @@ -19,21 +25,59 @@ import Cardano.Launcher ( LauncherLog, ProcessHasExited, withBackendCreateProcess ) import Control.Tracer ( Tracer (..) ) +import Data.Bifunctor + ( first ) +import Data.List + ( isPrefixOf ) import Data.Maybe ( maybeToList ) +import Data.Text.Class + ( FromText (..), TextDecodingError (..), ToText (..) ) import System.Environment ( getEnvironment ) import System.FilePath - ( takeFileName, () ) + ( isValid, takeFileName, () ) import System.Info ( os ) import UnliftIO.Process ( CreateProcess (..), proc ) +import qualified Data.Text as T + -- | Parameters for connecting to the node. -newtype CardanoNodeConn = CardanoNodeConn - { nodeSocketFile :: FilePath - } deriving (Show, Eq) +newtype CardanoNodeConn = CardanoNodeConn FilePath + deriving (Show, Eq) + +-- | Gets the socket filename or pipe name from 'CardanoNodeConn'. Whether it's +-- a unix socket or named pipe depends on the value of 'isWindows'. +nodeSocketFile :: CardanoNodeConn -> FilePath +nodeSocketFile (CardanoNodeConn name) = name + +-- | Produces a 'CardanoNodeConn' if the socket path or pipe name (depending on +-- '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 :: Bool +isWindows = os == "mingw32" + +isValidWindowsPipeName :: FilePath -> Bool +isValidWindowsPipeName name = slashPipe `isPrefixOf` name + && isValid (drop (length slashPipe) name) + where + slashPipe = "\\\\.\\pipe\\" + +instance ToText CardanoNodeConn where + toText = T.pack . nodeSocketFile + +instance FromText CardanoNodeConn where + fromText = first TextDecodingError . cardanoNodeConn . T.unpack newtype NodePort = NodePort { unNodePort :: Int } deriving (Show, Eq) diff --git a/lib/shelley/bench/Latency.hs b/lib/shelley/bench/Latency.hs index 2756baa9d62..d2b9db310c1 100644 --- a/lib/shelley/bench/Latency.hs +++ b/lib/shelley/bench/Latency.hs @@ -405,16 +405,16 @@ withShelleyServer tracers action = do let logCfg = LogFileConfig Error Nothing Error let clusterCfg = LocalClusterConfig [] maxBound logCfg withCluster nullTracer dir clusterCfg $ - onClusterStart act dir + onClusterStart act dir db - setupFaucet dir = do + setupFaucet conn dir = do let encodeAddr = T.unpack . encodeAddress @'Mainnet let addresses = map (first encodeAddr) shelleyIntegrationTestFunds - sendFaucetFundsTo nullTracer dir addresses + sendFaucetFundsTo nullTracer conn dir addresses - onClusterStart act db (RunningNode socketPath block0 (gp, vData)) = do + onClusterStart act dir db (RunningNode conn block0 (np, vData)) = do listen <- walletListenFromEnv - setupFaucet db + setupFaucet conn dir serveWallet (SomeNetworkDiscriminant $ Proxy @'Mainnet) tracers @@ -425,7 +425,7 @@ withShelleyServer tracers action = do listen Nothing Nothing - socketPath + conn block0 - (gp, vData) - (act gp) + (np, vData) + (act np) diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index 83396da316f..bcb411b6b64 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -35,7 +35,7 @@ -- @ -- stack bench cardano-wallet:bench:restore -- --ba 'mainnet -c $CONFIGURATION_DIR --- --running-node $SOCKET_PATH +-- --running-node $CARDANO_NODE_SOCKET_PATH -- @ -- -- This makes iteration easy, but requires you to have the configuration @@ -134,7 +134,7 @@ import Cardano.Wallet.Shelley import Cardano.Wallet.Shelley.Compatibility ( HasNetworkId (..), NodeVersionData, emptyGenesis, fromCardanoBlock ) import Cardano.Wallet.Shelley.Launch - ( NetworkConfiguration (..), parseGenesisData ) + ( CardanoNodeConn, NetworkConfiguration (..), parseGenesisData ) import Cardano.Wallet.Shelley.Network ( withNetworkLayer ) import Cardano.Wallet.Shelley.Transaction @@ -229,7 +229,7 @@ argsNetworkConfig args = case argNetworkName args of TestnetConfig (argsNetworkDir args "genesis-byron.json") -- | Run all available benchmarks. -cardanoRestoreBench :: Trace IO Text -> NetworkConfiguration -> FilePath -> IO () +cardanoRestoreBench :: Trace IO Text -> NetworkConfiguration -> CardanoNodeConn -> IO () cardanoRestoreBench tr c socketFile = do (SomeNetworkDiscriminant networkProxy, np, vData, _b) <- unsafeRunExceptT $ parseGenesisData c @@ -567,8 +567,7 @@ bench_restoration ) => Proxy n -> Tracer IO (BenchmarkLog n) - -> FilePath - -- ^ Socket path + -> CardanoNodeConn -- ^ Socket path -> NetworkParameters -> NodeVersionData -> Text -- ^ Benchmark name (used for naming resulting files) @@ -690,7 +689,7 @@ prepareNode :: forall n. (NetworkDiscriminantVal n) => Tracer IO (BenchmarkLog n) -> Proxy n - -> FilePath + -> CardanoNodeConn -> NetworkParameters -> NodeVersionData -> IO () diff --git a/lib/shelley/cardano-wallet.cabal b/lib/shelley/cardano-wallet.cabal index 42551820c20..9631f2a09a5 100644 --- a/lib/shelley/cardano-wallet.cabal +++ b/lib/shelley/cardano-wallet.cabal @@ -80,6 +80,7 @@ library , text-class , time , transformers + , typed-process , unliftio , unliftio-core , unordered-containers diff --git a/lib/shelley/exe/cardano-wallet.hs b/lib/shelley/exe/cardano-wallet.hs index b3f12471cef..398097d5541 100644 --- a/lib/shelley/exe/cardano-wallet.hs +++ b/lib/shelley/exe/cardano-wallet.hs @@ -62,6 +62,8 @@ import Cardano.CLI , tlsOption , withLogging ) +import Cardano.Launcher.Node + ( CardanoNodeConn ) import Cardano.Startup ( ShutdownHandlerLog , installSignalHandlers @@ -179,7 +181,7 @@ data ServeArgs = ServeArgs { _hostPreference :: HostPreference , _listen :: Listen , _tlsConfig :: Maybe TlsConfiguration - , _nodeSocket :: FilePath + , _nodeSocket :: CardanoNodeConn , _networkConfiguration :: NetworkConfiguration , _database :: Maybe FilePath , _syncTolerance :: SyncTolerance @@ -212,7 +214,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty host listen tlsConfig - nodeSocket + conn networkConfig databaseDir sTolerance @@ -241,7 +243,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty listen tlsConfig (fmap Settings poolMetadataFetching) - nodeSocket + conn block0 (gp, vData) (beforeMainLoop tr) diff --git a/lib/shelley/exe/shelley-test-cluster.hs b/lib/shelley/exe/shelley-test-cluster.hs index 8a837fa7657..2aba93e42d7 100644 --- a/lib/shelley/exe/shelley-test-cluster.hs +++ b/lib/shelley/exe/shelley-test-cluster.hs @@ -208,30 +208,30 @@ main :: IO () main = withLocalClusterSetup $ \dir clusterLogs walletLogs -> withLoggingNamed "test-cluster" clusterLogs $ \(_, (_, trCluster)) -> do let tr' = contramap MsgCluster $ trMessageText trCluster - clusterCfg <- localClusterConfigFromEnv + clusterCfg <- localClusterConfigFromEnv Nothing withCluster tr' dir clusterCfg $ whenReady dir (trMessageText trCluster) walletLogs where - setupFaucet dir trCluster = do + setupFaucet dir trCluster socketPath = do traceWith trCluster MsgSettingUpFaucet let trCluster' = contramap MsgCluster trCluster let encodeAddr = T.unpack . encodeAddress @'Mainnet let addresses = map (first encodeAddr) shelleyIntegrationTestFunds let accts = concatMap genRewardAccounts mirMnemonics let rewards = (,Coin $ fromIntegral oneMillionAda) <$> accts - sendFaucetFundsTo trCluster' dir addresses - moveInstantaneousRewardsTo trCluster' dir rewards + sendFaucetFundsTo trCluster' socketPath dir addresses + moveInstantaneousRewardsTo trCluster' socketPath dir rewards whenReady dir trCluster logs (RunningNode socketPath block0 (gp, vData)) = withLoggingNamed "cardano-wallet" logs $ \(sb, (cfg, tr)) -> do - setupFaucet dir trCluster + setupFaucet dir trCluster socketPath ekgEnabled >>= flip when (EKG.plugin cfg tr sb >>= loadPlugin sb) let tracers = setupTracers (tracerSeverities (Just Debug)) tr let db = dir "wallets" createDirectory db - listen <- walletListenFromEnv Nothing + listen <- walletListenFromEnv prometheusUrl <- (maybe "none" (\(h, p) -> T.pack h <> ":" <> toText @(Port "Prometheus") p) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 5977ffae37e..16a16c5df79 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -52,6 +52,8 @@ import Cardano.BM.Trace ( Trace, appendName, nullTracer ) import Cardano.DB.Sqlite ( DBLog ) +import Cardano.Launcher.Node + ( CardanoNodeConn ) import Cardano.Pool.DB ( DBLayer (..) ) import Cardano.Pool.DB.Log @@ -230,7 +232,7 @@ serveWallet -- ^ An optional TLS configuration -> Maybe Settings -- ^ Settings to be set at application start, will be written into DB. - -> FilePath + -> CardanoNodeConn -- ^ Socket for communicating with the node -> Block -- ^ The genesis block, or some starting point. @@ -255,12 +257,12 @@ serveWallet listen tlsConfig settings - socketPath + conn block0 (np, vData) beforeMainLoop = do let ntwrk = networkDiscriminantValFromProxy proxy - traceWith applicationTracer $ MsgStarting socketPath + traceWith applicationTracer $ MsgStarting conn traceWith applicationTracer $ MsgNetworkName ntwrk Server.withListeningSocket hostPref listen $ \case Left e -> handleApiServerStartupError e @@ -269,7 +271,7 @@ serveWallet poolDatabaseDecorator = fromMaybe Pool.undecoratedDB mPoolDatabaseDecorator serveApp socket = withIOManager $ \io -> do - withNetworkLayer networkTracer np socketPath vData $ \nl -> do + withNetworkLayer networkTracer np conn vData $ \nl -> do withWalletNtpClient io ntpClientTracer $ \ntpClient -> do let net = networkIdVal proxy randomApi <- apiLayer (newTransactionLayer net) nl @@ -437,7 +439,7 @@ exitCodeApiServer = \case -- | Log messages related to application startup and shutdown. data ApplicationLog - = MsgStarting FilePath + = MsgStarting CardanoNodeConn | MsgNetworkName Text | MsgServerStartupError ListenError | MsgFailedConnectSMASH URI @@ -445,9 +447,8 @@ data ApplicationLog instance ToText ApplicationLog where toText = \case - MsgStarting socket -> - let addr = T.pack $ show socket - in "Wallet backend server starting. Using " <> addr <> "." + MsgStarting conn -> + "Wallet backend server starting. Using " <> toText conn <> "." MsgNetworkName network -> "Node is Haskell Node on " <> network <> "." MsgServerStartupError startupErr -> case startupErr of diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs index 884d3575f58..9b8d8302bc7 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs @@ -27,6 +27,7 @@ module Cardano.Wallet.Shelley.Launch , LocalClusterConfig (..) , localClusterConfigFromEnv , ClusterEra (..) + , clusterEraName -- * Node launcher , NodeParams (..) @@ -57,6 +58,7 @@ module Cardano.Wallet.Shelley.Launch -- * Network , NetworkConfiguration (..) + , CardanoNodeConn , nodeSocketOption , networkConfigurationOption , parseGenesisData @@ -101,8 +103,11 @@ import Cardano.Launcher ( LauncherLog, ProcessHasExited (..) ) import Cardano.Launcher.Node ( CardanoNodeConfig (..) - , CardanoNodeConn (..) + , CardanoNodeConn , NodePort (..) + , cardanoNodeConn + , isWindows + , nodeSocketFile , withCardanoNode ) import Cardano.Pool.Metadata @@ -136,8 +141,6 @@ import Cardano.Wallet.Shelley.Compatibility ( NodeVersionData, StandardShelley ) import Cardano.Wallet.Unsafe ( unsafeFromHex, unsafeRunExceptT ) -import Control.Arrow - ( first, second ) import Control.Monad ( forM, forM_, replicateM, replicateM_, unless, void, when, (>=>) ) import Control.Monad.Fail @@ -154,6 +157,8 @@ import Crypto.Hash.Utils ( blake2b256 ) import Data.Aeson ( FromJSON (..), toJSON, (.:), (.=) ) +import Data.Bifunctor + ( first, second ) import Data.ByteArray.Encoding ( Base (..), convertToBase ) import Data.ByteString @@ -169,7 +174,7 @@ import Data.Function import Data.Functor ( ($>), (<&>) ) import Data.List - ( isInfixOf, isPrefixOf, nub, permutations, sort ) + ( nub, permutations, sort ) import Data.Maybe ( catMaybes, fromMaybe, isJust ) import Data.Proxy @@ -198,17 +203,23 @@ import Ouroboros.Network.NodeToClient import System.Directory ( copyFile, createDirectory, createDirectoryIfMissing, makeAbsolute ) import System.Environment - ( lookupEnv, setEnv ) + ( getEnvironment, lookupEnv ) import System.Exit ( ExitCode (..), die ) import System.FilePath - ( isValid, (<.>), () ) -import System.Info - ( os ) + ( (<.>), () ) import System.IO.Temp ( createTempDirectory, getCanonicalTemporaryDirectory ) import System.IO.Unsafe ( unsafePerformIO ) +import System.Process.Typed + ( ProcessConfig + , proc + , readProcess + , readProcessStdout_ + , setEnv + , setEnvInherit + ) import Test.Utils.Paths ( getTestData ) import Test.Utils.StaticServer @@ -222,9 +233,7 @@ import UnliftIO.Concurrent import UnliftIO.Exception ( SomeException, finally, handle, throwIO ) import UnliftIO.MVar - ( MVar, modifyMVar, newMVar, putMVar, readMVar, takeMVar ) -import UnliftIO.Process - ( readProcess, readProcessWithExitCode ) + ( MVar, modifyMVar, newMVar, putMVar, swapMVar, takeMVar ) import UnliftIO.Temporary ( withTempDirectory ) @@ -243,6 +252,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import qualified Data.Vector as V import qualified Data.Yaml as Yaml @@ -267,36 +277,19 @@ data NetworkConfiguration where deriving (Show, Eq) -- | --node-socket=FILE -nodeSocketOption :: Parser FilePath -nodeSocketOption = option (eitherReader check) $ mempty +nodeSocketOption :: Parser CardanoNodeConn +nodeSocketOption = option (eitherReader (addHelp . cardanoNodeConn)) $ mempty <> long "node-socket" <> metavar (if isWindows then "PIPENAME" else "FILE") <> help helpText where - check :: String -> Either String FilePath - check name - | isWindows = if isValidWindowsPipeName name - then Right name - else Left ("Invalid pipe name. " ++ pipeHelp) - | otherwise = if isValid name - then Right name - else Left "Invalid file path" - helpText = mconcat [ "Path to the node's domain socket file (POSIX) " , "or pipe name (Windows). " , "Note: Maximum length for POSIX socket files is approx. 100 bytes. " - , "Note: ", pipeHelp ] - pipeHelp = "Windows named pipes are of the form \\\\.\\pipe\\cardano-node" - -isWindows :: Bool -isWindows = os == "mingw32" - -isValidWindowsPipeName :: FilePath -> Bool -isValidWindowsPipeName name = slashPipe `isPrefixOf` name - && isValid (drop (length slashPipe) name) - where - slashPipe = "\\\\.\\pipe\\" + , "Note:", pipeHelp ] + pipeHelp = " Windows named pipes are of the form \\\\.\\pipe\\cardano-node" + addHelp = first (if isWindows then (++ pipeHelp) else id) -- | --mainnet --shelley-genesis=FILE -- --testnet --byron-genesis=FILE --shelley-genesis=FILE @@ -479,37 +472,74 @@ instance FromJSON PreserveInitialFundsOrdering where -- For Integration -------------------------------------------------------------------------------- +-- | Make a 'ProcessConfig' for running @cardano-cli@. The program must be on +-- the @PATH@, as normal. Sets @CARDANO_NODE_SOCKET_PATH@ for the subprocess, if +-- a 'CardanoNodeConn' is provided. +cliConfigBase + :: Tracer IO ClusterLog -- ^ for logging the command + -> Maybe CardanoNodeConn -- ^ optional cardano-node socket path + -> [String] -- ^ command-line arguments + -> IO (ProcessConfig () () ()) +cliConfigBase tr conn args = do + traceWith tr (MsgCLI args) + env <- getEnvironment + let mkEnv c = ("CARDANO_NODE_SOCKET_PATH", nodeSocketFile c):env + let cliEnv = maybe setEnvInherit (setEnv . mkEnv) conn + pure $ cliEnv $ proc "cardano-cli" args + +cliConfigNode + :: Tracer IO ClusterLog -- ^ for logging the command + -> CardanoNodeConn -- ^ cardano-node socket path + -> [String] -- ^ command-line arguments + -> IO (ProcessConfig () () ()) +cliConfigNode tr conn = cliConfigBase tr (Just conn) + +cliConfig + :: Tracer IO ClusterLog -- ^ for logging the command + -> [String] -- ^ command-line arguments + -> IO (ProcessConfig () () ()) +cliConfig tr = cliConfigBase tr Nothing + -- | A quick helper to interact with the 'cardano-cli'. Assumes the cardano-cli -- is available in PATH. -cli :: Tracer IO ClusterLog -> [String] -> IO String -cli tr args = do - traceWith tr $ MsgCLI args - readProcess "cardano-cli" args stdin - where - stdin = "" +cli :: Tracer IO ClusterLog -> [String] -> IO () +cli tr = cliConfig tr >=> void . readProcessStdout_ + +cliLine :: Tracer IO ClusterLog -> [String] -> IO String +cliLine tr = cliConfig tr >=> + fmap (BL8.unpack . getFirstLine) . readProcessStdout_ + +getFirstLine :: BL8.ByteString -> BL8.ByteString +getFirstLine = BL8.takeWhile (\c -> c /= '\r' && c /= '\n') + +-- | Like 'cli', but sets the node socket path. +cliNode + :: Tracer IO ClusterLog + -> CardanoNodeConn + -> [String] + -> IO (ExitCode, BL8.ByteString, BL8.ByteString) +cliNode tr conn = cliConfigNode tr conn >=> readProcess -- | Runs a @cardano-cli@ command and retries for up to 30 seconds if the -- command failed. -- --- Assumes @cardano-cli@ is available in @PATH@ and that the env var --- @CARDANO_NODE_SOCKET_PATH@ has already been set. +-- Assumes @cardano-cli@ is available in @PATH@. cliRetry :: Tracer IO ClusterLog - -> String -- ^ message to print before running command - -> [String] -- ^ arguments to @cardano-cli@ - -> IO String -cliRetry tr msg args = do + -> Text -- ^ message to print before running command + -> ProcessConfig () a b + -> IO () +cliRetry tr msg processConfig = do (st, out, err) <- retrying pol (const isFail) (const cmd) traceWith tr $ MsgCLIStatus msg st out err case st of - ExitSuccess -> pure out + ExitSuccess -> pure () ExitFailure _ -> throwIO $ ProcessHasExited - (unwords (prog:args) <> " failed: " <> err) st + ("cardano-cli failed: " <> BL8.unpack err) st where - prog = "cardano-cli" cmd = do traceWith tr $ MsgCLIRetry msg - (st, out, err) <- readProcessWithExitCode "cardano-cli" args mempty + (st, out, err) <- readProcess processConfig case st of ExitSuccess -> pure () ExitFailure code -> traceWith tr (MsgCLIRetryResult msg code err) @@ -587,7 +617,7 @@ data LocalClusterConfig = LocalClusterConfig -- | Information about a launched node. data RunningNode = RunningNode - FilePath + CardanoNodeConn -- ^ Socket path Block -- ^ Genesis block @@ -620,6 +650,7 @@ withCluster withCluster tr dir LocalClusterConfig{..} onClusterStart = bracketTracer' tr "withCluster" $ do traceWith tr $ MsgStartingCluster dir + resetGlobals putClusterEra dir cfgLastHardFork let poolCount = length cfgStakePools (port0:ports) <- randomUnusedTCPPorts (poolCount + 2) @@ -631,7 +662,7 @@ withCluster tr dir LocalClusterConfig{..} onClusterStart = (rawTx, faucetPrv) <- prepareKeyRegistration tr cfgLastHardFork dir tx <- signTx tr dir rawTx [faucetPrv] - submitTx tr "pre-registered stake key" tx + submitTx tr bftSocket "pre-registered stake key" tx waitGroup <- newChan doneGroup <- newChan @@ -729,7 +760,7 @@ withBFTNode -- this. -> NodeParams -- ^ Parameters used to generate config files. - -> (FilePath -> Block -> (NetworkParameters, NodeVersionData) -> IO a) + -> (CardanoNodeConn -> Block -> (NetworkParameters, NodeVersionData) -> IO a) -- ^ Callback function with genesis parameters -> IO a withBFTNode tr baseDir params action = @@ -770,7 +801,7 @@ withBFTNode tr baseDir params action = , nodeLoggingHostname = Just name } - withCardanoNodeProcess tr name cfg $ \(CardanoNodeConn socket) -> do + withCardanoNodeProcess tr name cfg $ \socket -> action socket block0 (networkParams, versionData) where name = "bft" @@ -788,7 +819,7 @@ withRelayNode -- this. -> NodeParams -- ^ Parameters used to generate config files. - -> (FilePath -> IO a) + -> (CardanoNodeConn -> IO a) -- ^ Callback function with socket path -> IO a withRelayNode tr baseDir params act = @@ -813,8 +844,7 @@ withRelayNode tr baseDir params act = , nodeLoggingHostname = Just name } - withCardanoNodeProcess tr name cfg $ \(CardanoNodeConn socket) -> - act socket + withCardanoNodeProcess tr name cfg act where name = "node" dir = baseDir name @@ -924,11 +954,11 @@ withStakePool tr baseDir idx params pledgeAmt poolConfig action = traceWith tr $ MsgStartedStaticServer dir url (cfg, opPub, tx) <- setupStakePoolData tr dir name params url pledgeAmt (retirementEpoch poolConfig) - withCardanoNodeProcess tr name cfg $ \_ -> do - submitTx tr name tx + withCardanoNodeProcess tr name cfg $ \socket -> do + submitTx tr socket name tx timeout 120 ( "pool registration" - , waitUntilRegistered tr name (nodeHardForks params) opPub ) + , waitUntilRegistered tr socket name (nodeHardForks params) opPub ) action where dir = baseDir name @@ -946,8 +976,7 @@ withSMASH parentDir action = do let baseDir = staticDir "api" "v1" -- write pool metadatas - pools <- readMVar operators - forM_ pools $ \(poolId, _, _, _, metadata) -> do + forM_ operatorsFixture $ \(poolId, _, _, _, metadata) -> do let bytes = Aeson.encode metadata let metadataDir = baseDir "metadata" @@ -1129,7 +1158,7 @@ genKesKeyPair :: Tracer IO ClusterLog -> FilePath -> IO (FilePath, FilePath) genKesKeyPair tr dir = do let kesPub = dir "kes.pub" let kesPrv = dir "kes.prv" - void $ cli tr + cli tr [ "node", "key-gen-KES" , "--verification-key-file", kesPub , "--signing-key-file", kesPrv @@ -1141,7 +1170,7 @@ genVrfKeyPair :: Tracer IO ClusterLog -> FilePath -> IO (FilePath, FilePath) genVrfKeyPair tr dir = do let vrfPub = dir "vrf.pub" let vrfPrv = dir "vrf.prv" - void $ cli tr + cli tr [ "node", "key-gen-VRF" , "--verification-key-file", vrfPub , "--signing-key-file", vrfPrv @@ -1153,7 +1182,7 @@ genStakeAddrKeyPair :: Tracer IO ClusterLog -> FilePath -> IO (FilePath, FilePat genStakeAddrKeyPair tr dir = do let stakePub = dir "stake.pub" let stakePrv = dir "stake.prv" - void $ cli tr + cli tr [ "stake-address", "key-gen" , "--verification-key-file", stakePub , "--signing-key-file", stakePrv @@ -1164,7 +1193,7 @@ genStakeAddrKeyPair tr dir = do issueOpCert :: Tracer IO ClusterLog -> FilePath -> FilePath -> FilePath -> FilePath -> IO FilePath issueOpCert tr dir kesPub opPrv opCount = do let file = dir "op.cert" - void $ cli tr + cli tr [ "node", "issue-op-cert" , "--kes-verification-key-file", kesPub , "--cold-signing-key-file", opPrv @@ -1183,7 +1212,7 @@ issueStakeCert -> IO FilePath issueStakeCert tr dir prefix stakePub = do let file = dir prefix <> "-stake.cert" - void $ cli tr + cli tr [ "stake-address", "registration-certificate" , "--staking-verification-key-file", stakePub , "--out-file", file @@ -1206,7 +1235,7 @@ issuePoolRegistrationCert let file = dir "pool.cert" let bytes = Aeson.encode metadata BL8.writeFile (dir "metadata.json") bytes - void $ cli tr + cli tr [ "stake-pool", "registration-certificate" , "--cold-verification-key-file", opPub , "--vrf-verification-key-file", vrfPub @@ -1230,7 +1259,7 @@ issuePoolRetirementCert -> IO FilePath issuePoolRetirementCert tr dir opPub retirementEpoch = do let file = dir "pool-retirement.cert" - void $ cli tr + cli tr [ "stake-pool", "deregistration-certificate" , "--cold-verification-key-file", opPub , "--epoch", show (unEpochNo retirementEpoch) @@ -1242,7 +1271,7 @@ issuePoolRetirementCert tr dir opPub retirementEpoch = do issueDlgCert :: Tracer IO ClusterLog -> FilePath -> FilePath -> FilePath -> IO FilePath issueDlgCert tr dir stakePub opPub = do let file = dir "dlg.cert" - void $ cli tr + cli tr [ "stake-address", "delegation-certificate" , "--staking-verification-key-file", stakePub , "--stake-pool-verification-key-file", opPub @@ -1264,12 +1293,12 @@ preparePoolRegistration tr era dir stakePub certs pledgeAmt = do let file = dir "tx.raw" let sinkPrv = dir "sink.prv" let sinkPub = dir "sink.pub" - void $ cli tr + cli tr [ "address", "key-gen" , "--signing-key-file", sinkPrv , "--verification-key-file", sinkPub ] - addr <- cli tr + addr <- cliLine tr [ "address", "build" , "--payment-verification-key-file", sinkPub , "--stake-verification-key-file", stakePub @@ -1277,10 +1306,10 @@ preparePoolRegistration tr era dir stakePub certs pledgeAmt = do ] (faucetInput, faucetPrv) <- takeFaucet - void $ cli tr $ + cli tr $ [ "transaction", "build-raw" , "--tx-in", faucetInput - , "--tx-out", init addr <> "+" <> show pledgeAmt + , "--tx-out", addr <> "+" <> show pledgeAmt , "--ttl", "400" , "--fee", show (faucetAmt - pledgeAmt - depositAmt) , "--out-file", file @@ -1291,10 +1320,11 @@ preparePoolRegistration tr era dir stakePub certs pledgeAmt = do sendFaucetFundsTo :: Tracer IO ClusterLog + -> CardanoNodeConn -> FilePath -> [(String, Coin)] -> IO () -sendFaucetFundsTo tr dir allTargets = do +sendFaucetFundsTo tr conn dir allTargets = do forM_ (group 80 allTargets) sendBatch where sendBatch targets = do @@ -1307,7 +1337,7 @@ sendFaucetFundsTo tr dir allTargets = do when (total > faucetAmt) $ error "sendFaucetFundsTo: too much to pay" era <- getClusterEra dir - void $ cli tr $ + cli tr $ [ "transaction", "build-raw" , "--tx-in", faucetInput , "--ttl", "600" @@ -1317,7 +1347,7 @@ sendFaucetFundsTo tr dir allTargets = do ] ++ outputs tx <- signTx tr dir file [faucetPrv] - submitTx tr "faucet tx" tx + submitTx tr conn "faucet tx" tx -- TODO: Use split package? -- https://stackoverflow.com/questions/12876384/grouping-a-list-into-lists-of-n-elements-in-haskell @@ -1329,10 +1359,11 @@ sendFaucetFundsTo tr dir allTargets = do moveInstantaneousRewardsTo :: Tracer IO ClusterLog + -> CardanoNodeConn -> FilePath -> [(XPub, Coin)] -> IO () -moveInstantaneousRewardsTo tr dir targets = do +moveInstantaneousRewardsTo tr conn dir targets = do certs <- mapM (mkVerificationKey >=> mkMIRCertificate) targets (faucetInput, faucetPrv) <- takeFaucet let file = dir "mir-tx.raw" @@ -1344,7 +1375,7 @@ moveInstantaneousRewardsTo tr dir targets = do sink <- genSinkAddress tr dir era <- getClusterEra dir - void $ cli tr $ + cli tr $ [ "transaction", "build-raw" , "--tx-in", faucetInput , "--ttl", "600" @@ -1358,7 +1389,7 @@ moveInstantaneousRewardsTo tr dir targets = do let bftPrv = testData "bft-leader" <> ".skey" tx <- signTx tr dir file [faucetPrv, bftPrv] - submitTx tr "MIR certificates" tx + submitTx tr conn "MIR certificates" tx where mkVerificationKey :: (XPub, Coin) @@ -1380,7 +1411,7 @@ moveInstantaneousRewardsTo tr dir targets = do mkMIRCertificate (pub, stakeVK, Coin reward) = do let mirCert = dir pub <> ".mir" stakeCert <- issueStakeCert tr dir pub stakeVK - void $ cli tr + cli tr [ "governance", "create-mir-certificate" , "--reserves" , "--reward", show reward @@ -1407,7 +1438,7 @@ prepareKeyRegistration tr era dir = do cert <- issueStakeCert tr dir "pre-registered" stakePub sink <- genSinkAddress tr dir - void $ cli tr + cli tr [ "transaction", "build-raw" , "--tx-in", faucetInput , "--tx-out", sink <> "+" <> "1000000" @@ -1426,17 +1457,16 @@ genSinkAddress genSinkAddress tr dir = do let sinkPrv = dir "sink.prv" let sinkPub = dir "sink.pub" - void $ cli tr + cli tr [ "address", "key-gen" , "--signing-key-file", sinkPrv , "--verification-key-file", sinkPub ] - addr <- cli tr + cliLine tr [ "address", "build" , "--payment-verification-key-file", sinkPub , "--mainnet" ] - pure (init addr) -- | Sign a transaction with all the necessary signatures. signTx @@ -1447,7 +1477,7 @@ signTx -> IO FilePath signTx tr dir rawTx keys = do let file = dir "tx.signed" - void $ cli tr $ + cli tr $ [ "transaction", "sign" , "--tx-body-file", rawTx , "--mainnet" @@ -1456,9 +1486,10 @@ signTx tr dir rawTx keys = do pure file -- | Submit a transaction through a running node. -submitTx :: Tracer IO ClusterLog -> String -> FilePath -> IO () -submitTx tr name signedTx = do - void $ cliRetry tr ("Submitting transaction for " ++ name) +submitTx :: Tracer IO ClusterLog -> CardanoNodeConn -> String -> FilePath -> IO () +submitTx tr conn name signedTx = + cliRetry tr ("Submitting transaction for " <> T.pack name) =<< + cliConfigNode tr conn [ "transaction", "submit" , "--tx-file", signedTx , "--mainnet", "--cardano-mode" @@ -1469,38 +1500,34 @@ submitTx tr name signedTx = do -- -- It retries every second, for up to 30 seconds. An exception is thrown if -- it has waited for too long. --- --- As a side effect, after this subroutine finishes, the environment variable --- @CARDANO_NODE_SOCKET_PATH@ is set. -waitForSocket :: Tracer IO ClusterLog -> FilePath -> IO () -waitForSocket tr socketPath = do - setEnv "CARDANO_NODE_SOCKET_PATH" socketPath - let msg = "Checking for usable socket file " <> socketPath +waitForSocket :: Tracer IO ClusterLog -> CardanoNodeConn -> IO () +waitForSocket tr conn = do + let msg = "Checking for usable socket file " <> toText conn -- TODO: check whether querying the tip works just as well. - void $ cliRetry tr msg + cliRetry tr msg =<< cliConfigNode tr conn ["query", "tip" , "--mainnet" --, "--testnet-magic", "764824073" , "--cardano-mode" ] - traceWith tr $ MsgSocketIsReady socketPath + traceWith tr $ MsgSocketIsReady conn -- | Wait until a stake pool shows as registered on-chain. -waitUntilRegistered :: Tracer IO ClusterLog -> String -> ClusterEra -> FilePath -> IO () -waitUntilRegistered tr name era opPub = do - poolId <- init <$> cli tr +waitUntilRegistered :: Tracer IO ClusterLog -> CardanoNodeConn -> String -> ClusterEra -> FilePath -> IO () +waitUntilRegistered tr conn name era opPub = do + poolId <- fmap getFirstLine . readProcessStdout_ =<< cliConfig tr [ "stake-pool", "id" , "--stake-pool-verification-key-file", opPub ] - (exitCode, distribution, err) <- readProcessWithExitCode "cardano-cli" + (exitCode, distribution, err) <- cliNode tr conn [ "query", "stake-distribution" , "--mainnet" , cardanoCliEra era - ] mempty + ] traceWith tr $ MsgStakeDistribution name exitCode distribution err - unless (poolId `isInfixOf` distribution) $ do + unless (BL8.toStrict poolId `BS.isInfixOf` BL8.toStrict distribution) $ do threadDelay 5000000 - waitUntilRegistered tr name era opPub + waitUntilRegistered tr conn name era opPub -- | Hard-wired faucets referenced in the genesis file. Purpose is simply to @@ -1529,7 +1556,11 @@ faucetIndex = unsafePerformIO $ newMVar 1 {-# NOINLINE faucetIndex #-} operators :: MVar [(PoolId, Aeson.Value, Aeson.Value, Aeson.Value, Aeson.Value)] -operators = unsafePerformIO $ newMVar +operators = unsafePerformIO $ newMVar operatorsFixture +{-# NOINLINE operators #-} + +operatorsFixture :: [(PoolId, Aeson.Value, Aeson.Value, Aeson.Value, Aeson.Value)] +operatorsFixture = [ ( PoolId $ unsafeFromHex "ec28f33dcbe6d6400a1e5e339bd0647c0973ca6c0cf9c2bbe6838dc6" , Aeson.object @@ -1639,7 +1670,12 @@ operators = unsafePerformIO $ newMVar ] ) ] -{-# NOINLINE operators #-} + +-- | Allow running the test cluster a second time in the same process. +resetGlobals :: IO () +resetGlobals = do + void $ swapMVar faucetIndex 1 + void $ swapMVar operators operatorsFixture cardanoCliEra :: ClusterEra -> String cardanoCliEra era = "--" ++ clusterEraName era ++ "-era" @@ -1814,11 +1850,11 @@ data ClusterLog | MsgStartedStaticServer String FilePath | MsgTempDir TempDirLog | MsgBracket Text BracketLog - | MsgCLIStatus String ExitCode String String - | MsgCLIRetry String - | MsgCLIRetryResult String Int String - | MsgSocketIsReady FilePath - | MsgStakeDistribution String ExitCode String String + | MsgCLIStatus Text ExitCode BL8.ByteString BL8.ByteString + | MsgCLIRetry Text + | MsgCLIRetryResult Text Int BL8.ByteString + | MsgSocketIsReady CardanoNodeConn + | MsgStakeDistribution String ExitCode BL8.ByteString BL8.ByteString | MsgDebug Text | MsgGenOperatorKeyPair FilePath | MsgCLI [String] @@ -1845,15 +1881,15 @@ instance ToText ClusterLog where MsgTempDir msg -> toText msg MsgBracket name b -> name <> ": " <> toText b MsgCLIStatus msg st out err -> case st of - ExitSuccess -> "Successfully finished " <> T.pack msg - ExitFailure code -> "Failed " <> T.pack msg <> " with exit code " <> + ExitSuccess -> "Successfully finished " <> msg + ExitFailure code -> "Failed " <> msg <> " with exit code " <> T.pack (show code) <> ":\n" <> indent out <> "\n" <> indent err - MsgCLIRetry msg -> T.pack msg + MsgCLIRetry msg -> msg MsgCLIRetryResult msg code err -> - "Failed " <> T.pack msg <> " with exit code " <> + "Failed " <> msg <> " with exit code " <> T.pack (show code) <> ":\n" <> indent err - MsgSocketIsReady socketPath -> - T.pack socketPath <> " is ready." + MsgSocketIsReady conn -> + toText conn <> " is ready." MsgStakeDistribution name st out err -> case st of ExitSuccess -> "Stake distribution query for " <> T.pack name <> @@ -1866,7 +1902,7 @@ instance ToText ClusterLog where "Generating stake pool operator key pair in " <> T.pack dir MsgCLI args -> T.pack $ unwords ("cardano-cli":args) where - indent = T.unlines . map (" " <>) . T.lines . T.pack + indent = T.unlines . map (" " <>) . T.lines . T.decodeUtf8With T.lenientDecode . BL8.toStrict instance HasPrivacyAnnotation ClusterLog instance HasSeverityAnnotation ClusterLog where diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index fe26a03e8b5..d489177c856 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -43,6 +43,8 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Launcher.Node + ( CardanoNodeConn, nodeSocketFile ) import Cardano.Wallet.Byron.Compatibility ( byronCodecConfig, protocolParametersFromUpdateState ) import Cardano.Wallet.Logging @@ -287,26 +289,26 @@ withNetworkLayer -- ^ Logging of network layer startup -> W.NetworkParameters -- ^ Initial blockchain parameters - -> FilePath + -> CardanoNodeConn -- ^ Socket for communicating with the node -> (NodeToClientVersionData, CodecCBORTerm Text NodeToClientVersionData) -- ^ Codecs for the node's client -> (NetworkLayer IO (CardanoBlock StandardCrypto) -> IO a) -- ^ Callback function with the network layer -> IO a -withNetworkLayer trBase np addrInfo ver action = do +withNetworkLayer trBase np conn ver action = do tr <- addTimings trBase - withNetworkLayerBase tr np addrInfo ver action + withNetworkLayerBase tr np conn ver action withNetworkLayerBase :: HasCallStack => Tracer IO NetworkLayerLog -> W.NetworkParameters - -> FilePath + -> CardanoNodeConn -> (NodeToClientVersionData, CodecCBORTerm Text NodeToClientVersionData) -> (NetworkLayer IO (CardanoBlock StandardCrypto) -> IO a) -> IO a -withNetworkLayerBase tr np addrInfo (versionData, _) action = do +withNetworkLayerBase tr np conn (versionData, _) action = do -- NOTE: We keep client connections running for accessing the node tip, -- submitting transactions, querying parameters and delegations/rewards. -- @@ -413,7 +415,7 @@ withNetworkLayerBase tr np addrInfo (versionData, _) action = do (writeChan nodeTipChan) (curry (atomically . writeTVar networkParamsVar)) (atomically . repsertTMVar interpreterVar) - link =<< async (connectClient tr handlers nodeTipClient versionData addrInfo) + link =<< async (connectClient tr handlers nodeTipClient versionData conn) pure (nodeTipChan, networkParamsVar, interpreterVar, localTxSubmissionQ) connectDelegationRewardsClient @@ -424,7 +426,7 @@ withNetworkLayerBase tr np addrInfo (versionData, _) action = do connectDelegationRewardsClient handlers = do cmdQ <- atomically newTQueue let cl = mkDelegationRewardsClient tr cfg cmdQ - link =<< async (connectClient tr handlers cl versionData addrInfo) + link =<< async (connectClient tr handlers cl versionData conn) pure cmdQ _initCursor :: HasCallStack => [W.BlockHeader] -> IO Cursor @@ -432,7 +434,7 @@ withNetworkLayerBase tr np addrInfo (versionData, _) action = do chainSyncQ <- atomically newTQueue client <- mkWalletClient (contramap MsgChainSyncCmd tr) cfg gp chainSyncQ let handlers = failOnConnectionLost tr - thread <- async (connectClient tr handlers client versionData addrInfo) + thread <- async (connectClient tr handlers client versionData conn) link thread let points = reverse $ genesisPoint : (toPoint getGenesisBlockHash <$> headers) @@ -1184,24 +1186,24 @@ doNothingProtocol = -- Connect a client to a network, see `mkWalletClient` to construct a network -- client interface. -- --- >>> connectClient (mkWalletClient tr gp queue) mainnetVersionData addrInfo +-- >>> connectClient (mkWalletClient tr gp queue) mainnetVersionData conn connectClient :: Tracer IO NetworkLayerLog -> RetryHandlers -> NetworkClient IO -> NodeToClientVersionData - -> FilePath + -> CardanoNodeConn -> IO () -connectClient tr handlers client vData addr = withIOManager $ \iocp -> do +connectClient tr handlers client vData conn = withIOManager $ \iocp -> do let versions = simpleSingletonVersions nodeToClientVersion vData client let tracers = NetworkConnectTracers { nctMuxTracer = nullTracer , nctHandshakeTracer = contramap MsgHandshakeTracer tr } - let socket = localSnocket iocp addr + let socket = localSnocket iocp (nodeSocketFile conn) recovering policy (coerceHandlers handlers) $ \status -> do traceWith tr $ MsgCouldntConnect (rsIterNumber status) - connectTo socket tracers versions addr + connectTo socket tracers versions (nodeSocketFile conn) where -- .25s -> .25s -> .5s → .75s → 1.25s → 2s policy :: RetryPolicyM IO diff --git a/lib/shelley/test/integration/Main.hs b/lib/shelley/test/integration/Main.hs index ce873bd9d86..f670f5dd2ac 100644 --- a/lib/shelley/test/integration/Main.hs +++ b/lib/shelley/test/integration/Main.hs @@ -62,6 +62,7 @@ import Cardano.Wallet.Shelley.Launch ( ClusterEra (..) , ClusterLog , RunningNode (..) + , clusterEraName , localClusterConfigFromEnv , moveInstantaneousRewardsTo , oneMillionAda @@ -159,34 +160,35 @@ main = withTestsSetup $ \testDir tracers -> hspec $ do parallel' $ describe "Miscellaneous CLI tests" MiscellaneousCLI.spec - parallel $ testEras $ \era -> specWithServer testDir tracers (Just era) $ do - describe "API Specifications" $ do - Addresses.spec @n - CoinSelections.spec @n - ByronAddresses.spec @n - ByronCoinSelections.spec @n - Wallets.spec @n - ByronWallets.spec @n - HWWallets.spec @n - Migrations.spec @n - ByronMigrations.spec @n - Transactions.spec @n - Network.spec - Network_.spec - StakePools.spec @n - ByronTransactions.spec @n - ByronHWWallets.spec @n + testEras $ \era -> + specWithServer (testDir clusterEraName era) tracers (Just era) $ do + parallel $ describe "API Specifications" $ do + Addresses.spec @n + CoinSelections.spec @n + ByronAddresses.spec @n + ByronCoinSelections.spec @n + Wallets.spec @n + ByronWallets.spec @n + HWWallets.spec @n + Migrations.spec @n + ByronMigrations.spec @n + Transactions.spec @n + Network.spec + Network_.spec + StakePools.spec @n + ByronTransactions.spec @n + ByronHWWallets.spec @n - -- Possible conflict with StakePools - mark as not parallizable - sequential $ Settings.spec @n + -- Possible conflict with StakePools - mark as not parallizable + sequential $ Settings.spec @n - parallel' $ describe "CLI Specifications" $ do - AddressesCLI.spec @n - TransactionsCLI.spec @n - WalletsCLI.spec @n - HWWalletsCLI.spec @n - PortCLI.spec - NetworkCLI.spec + parallel' $ describe "CLI Specifications" $ do + AddressesCLI.spec @n + TransactionsCLI.spec @n + WalletsCLI.spec @n + HWWalletsCLI.spec @n + PortCLI.spec + NetworkCLI.spec where -- Hydra runs tests with code coverage enabled. CLI tests run -- multiple processes. These processes can try to write to the @@ -200,7 +202,7 @@ main = withTestsSetup $ \testDir tracers -> hspec $ do parallelIf flag = if flag then parallel else sequential - testEras run = forM_ [MaryHardFork] $ + testEras run = forM_ [MaryHardFork, AllegraHardFork] $ \era -> describe (show era) $ run era -- | Do all the program setup required for integration tests, create a temporary @@ -219,11 +221,10 @@ withTestsSetup action = do -- This temporary directory will contain logs, and all other data -- produced by the integration tests. withSystemTempDir stdoutTextTracer "test" $ \testDir -> - withTracers testDir $ \tracers -> - action testDir tracers + withTracers testDir $ action testDir specWithServer - :: FilePath + :: FilePath -- ^ Temporary directory, will be created. -> (Tracer IO TestsLog, Tracers IO) -> Maybe ClusterEra -> SpecWith Context @@ -232,6 +233,7 @@ specWithServer testDir (tr, tracers) era = aroundAll withContext where withContext :: (Context -> IO ()) -> IO () withContext action = bracketTracer' tr "withContext" $ do + createDirectory testDir ctx <- newEmptyMVar poolGarbageCollectionEvents <- newIORef [] let dbEventRecorder = @@ -240,18 +242,16 @@ specWithServer testDir (tr, tracers) era = aroundAll withContext let baseUrl = "http://" <> T.pack (show wAddr) <> "/" prometheusUrl <- (maybe "none" (\(h, p) -> T.pack h <> ":" <> toText @(Port "Prometheus") p)) <$> getPrometheusURL ekgUrl <- (maybe "none" (\(h, p) -> T.pack h <> ":" <> toText @(Port "EKG") p)) <$> getEKGURL - traceWith tr $ - MsgBaseUrl baseUrl ekgUrl prometheusUrl smashUrl - let fiveMinutes = 300*1000*1000 -- 5 minutes in microseconds - manager <- (baseUrl,) <$> newManager (defaultManagerSettings - { managerResponseTimeout = - responseTimeoutMicro fiveMinutes - }) + traceWith tr $ MsgBaseUrl baseUrl ekgUrl prometheusUrl smashUrl + let fiveMinutes = 300 * 1000 * 1000 -- 5 minutes in microseconds + manager <- newManager $ defaultManagerSettings + { managerResponseTimeout = responseTimeoutMicro fiveMinutes + } faucet <- initFaucet putMVar ctx $ Context { _cleanup = pure () - , _manager = manager + , _manager = (baseUrl, manager) , _walletPort = Port . fromIntegral $ unsafePortNumber wAddr , _faucet = faucet , _feeEstimator = error "feeEstimator: unused in shelley specs" @@ -284,7 +284,7 @@ specWithServer testDir (tr, tracers) era = aroundAll withContext let event = PoolGarbageCollectionEvent epochNo certificates liftIO $ do traceWith tr $ MsgPoolGarbageCollectionEvent event - atomicModifyIORef' eventsRef ((, ()) . (event :)) + atomicModifyIORef' eventsRef ((,()) . (event :)) pure certificates withServer dbDecorator onReady = bracketTracer' tr "withServer" $ @@ -294,17 +294,17 @@ specWithServer testDir (tr, tracers) era = aroundAll withContext onClusterStart (onReady $ T.pack smashUrl) dbDecorator tr' = contramap MsgCluster tr - setupFaucet = do + setupFaucet conn = do traceWith tr MsgSettingUpFaucet let rewards = (,Coin $ fromIntegral oneMillionAda) <$> concatMap genRewardAccounts mirMnemonics - moveInstantaneousRewardsTo tr' testDir rewards + moveInstantaneousRewardsTo tr' conn testDir rewards let encodeAddr = T.unpack . encodeAddress @'Mainnet let addresses = map (first encodeAddr) shelleyIntegrationTestFunds - sendFaucetFundsTo tr' testDir addresses + sendFaucetFundsTo tr' conn testDir addresses - onClusterStart action dbDecorator node = do - setupFaucet + onClusterStart action dbDecorator (RunningNode conn block0 (gp, vData)) = do + setupFaucet conn let db = testDir "wallets" createDirectory db listen <- walletListenFromEnv @@ -318,13 +318,11 @@ specWithServer testDir (tr, tracers) era = aroundAll withContext listen Nothing Nothing - socketPath + conn block0 (gp, vData) (action gp) `withException` (traceWith tr . MsgServerError) - where - RunningNode socketPath block0 (gp, vData) = node {------------------------------------------------------------------------------- Logging @@ -387,7 +385,8 @@ withTracers testDir action = do logDir <- fromMaybe testDir <$> testLogDirFromEnv pure [ LogToFile (logDir name) (min minSev Info) - , LogToStdout minSev ] + , LogToStdout minSev + ] walletLogOutputs <- getLogOutputs walletMinSeverityFromEnv "wallet.log" testLogOutputs <- getLogOutputs testMinSeverityFromEnv "test.log" diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs index 23725419e62..3a55645fb92 100644 --- a/lib/shelley/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs +++ b/lib/shelley/test/unit/Cardano/Wallet/Shelley/NetworkSpec.hs @@ -19,7 +19,12 @@ import Cardano.Wallet.Primitive.Types import Cardano.Wallet.Shelley.Compatibility ( NodeVersionData ) import Cardano.Wallet.Shelley.Launch - ( ClusterLog (..), singleNodeParams, withBFTNode, withSystemTempDir ) + ( CardanoNodeConn + , ClusterLog (..) + , singleNodeParams + , withBFTNode + , withSystemTempDir + ) import Cardano.Wallet.Shelley.Network ( Observer (..), ObserverLog (..), newObserver, withNetworkLayer ) import Control.Applicative @@ -221,7 +226,7 @@ spec = describe "NetworkLayer regression test #1708" $ do withTestNode :: Tracer IO ClusterLog - -> (NetworkParameters -> FilePath -> NodeVersionData -> IO a) + -> (NetworkParameters -> CardanoNodeConn -> NodeVersionData -> IO a) -> IO a withTestNode tr action = do cfg <- singleNodeParams Error Nothing