From 86609ef4467716448f65163ee37e341bf327fec7 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 11 Oct 2024 13:12:53 +0200 Subject: [PATCH] Remove redundant functions used for starting a process --- cardano-testnet/src/Testnet/Process/Run.hs | 150 ++---------------- cardano-testnet/src/Testnet/Property/Util.hs | 52 +----- cardano-testnet/src/Testnet/Runtime.hs | 6 +- .../Cardano/Testnet/Test/Node/Shutdown.hs | 21 ++- 4 files changed, 28 insertions(+), 201 deletions(-) diff --git a/cardano-testnet/src/Testnet/Process/Run.hs b/cardano-testnet/src/Testnet/Process/Run.hs index 8c0be2f8612..a9c96edc91a 100644 --- a/cardano-testnet/src/Testnet/Process/Run.hs +++ b/cardano-testnet/src/Testnet/Process/Run.hs @@ -17,7 +17,6 @@ module Testnet.Process.Run , mkExecConfig , mkExecConfigOffline , ProcessError(..) - , ExecutableError(..) ) where import Prelude @@ -30,18 +29,12 @@ import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra import Control.Monad.Trans.Resource import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LBS -import Data.Function -import qualified Data.List as List import Data.Monoid (Last (..)) import Data.String (fromString) -import qualified Data.Text as Text import GHC.Stack (HasCallStack) import qualified GHC.Stack as GHC -import qualified System.Directory as IO import qualified System.Environment as IO import System.Exit (ExitCode) -import System.FilePath import System.IO import qualified System.IO.Unsafe as IO import qualified System.Process as IO @@ -49,9 +42,7 @@ import System.Process import Hedgehog (MonadTest) import qualified Hedgehog.Extras as H -import Hedgehog.Extras.Internal.Plan (Component (..), Plan (..)) import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO -import qualified Hedgehog.Extras.Stock.OS as OS import Hedgehog.Extras.Test.Process (ExecConfig) import qualified Hedgehog.Internal.Property as H @@ -73,14 +64,14 @@ execCli :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => [String] -> m String -execCli = GHC.withFrozenCallStack $ H.execFlex "cardano-cli" "CARDANO_CLI" +execCli = GHC.withFrozenCallStack $ H.evalM . H.execFlex "cardano-cli" "CARDANO_CLI" -- | Run cardano-cli, discarding return value execCli_ :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => [String] -> m () -execCli_ = GHC.withFrozenCallStack $ void . execCli +execCli_ = GHC.withFrozenCallStack $ void . H.evalM . execCli -- | Run cardano-cli, returning the stdout execCli' @@ -88,7 +79,7 @@ execCli' => ExecConfig -> [String] -> m String -execCli' execConfig = GHC.withFrozenCallStack $ H.execFlex' execConfig "cardano-cli" "CARDANO_CLI" +execCli' execConfig = GHC.withFrozenCallStack $ H.evalM . H.execFlex' execConfig "cardano-cli" "CARDANO_CLI" -- | Run cardano-cli, returning the exit code, the stdout, and the stderr. -- Contrary to other functions from this module, this function doesn't fail the test @@ -98,7 +89,7 @@ execCliAny => ExecConfig -> [String] -> m (ExitCode, String, String) -- ^ The exit code of the call, stdout, stderr. -execCliAny execConfig = GHC.withFrozenCallStack $ H.execFlexAny' execConfig "cardano-cli" "CARDANO_CLI" +execCliAny execConfig = GHC.withFrozenCallStack $ H.evalM . H.execFlexAny' execConfig "cardano-cli" "CARDANO_CLI" -- | Run create-script-context, returning the stdout. execCreateScriptContext @@ -106,7 +97,7 @@ execCreateScriptContext => [String] -> m String execCreateScriptContext = - GHC.withFrozenCallStack $ H.execFlex "create-script-context" "CREATE_SCRIPT_CONTEXT" + GHC.withFrozenCallStack $ H.evalM . H.execFlex "create-script-context" "CREATE_SCRIPT_CONTEXT" -- | Run create-script-context, returning the stdout. execCreateScriptContext' @@ -115,7 +106,7 @@ execCreateScriptContext' -> [String] -> m String execCreateScriptContext' execConfig = - GHC.withFrozenCallStack $ H.execFlex' execConfig "create-script-context" "CREATE_SCRIPT_CONTEXT" + GHC.withFrozenCallStack $ H.evalM . H.execFlex' execConfig "create-script-context" "CREATE_SCRIPT_CONTEXT" -- | Call a command of the CLI that returns JSON to stdout. Then parse it, -- and deserialize it to a Haskell value. Fail the test if a step fails. @@ -139,18 +130,17 @@ procCli -- ^ Arguments to the CLI command -> m CreateProcess -- ^ Captured stdout -procCli = GHC.withFrozenCallStack $ H.procFlex "cardano-cli" "CARDANO_CLI" +procCli = GHC.withFrozenCallStack $ H.evalM . H.procFlex "cardano-cli" "CARDANO_CLI" -- | Create a 'CreateProcess' describing how to start the cardano-node process -- and an argument list. procNode - :: HasCallStack - => MonadIO m + :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => [String] -- ^ Arguments to the CLI command - -> ExceptT ExecutableError m CreateProcess + -> m CreateProcess -- ^ Captured stdout -procNode = GHC.withFrozenCallStack $ procFlexNew "cardano-node" "CARDANO_NODE" +procNode = GHC.withFrozenCallStack $ H.evalM . H.procFlex "cardano-node" "CARDANO_NODE" -- | Create a 'CreateProcess' describing how to start the cardano-submit-api process -- and an argument list. @@ -160,7 +150,7 @@ procSubmitApi -- ^ Arguments to the CLI command -> m CreateProcess -- ^ Captured stdout -procSubmitApi = GHC.withFrozenCallStack $ H.procFlex "cardano-submit-api" "CARDANO_SUBMIT_API" +procSubmitApi = GHC.withFrozenCallStack $ H.evalM . H.procFlex "cardano-submit-api" "CARDANO_SUBMIT_API" -- | Create a 'CreateProcess' describing how to start the cardano-node-chairman process -- and an argument list. @@ -170,7 +160,7 @@ procChairman -- ^ Arguments to the CLI command -> m CreateProcess -- ^ Captured stdout -procChairman = GHC.withFrozenCallStack $ H.procFlex "cardano-node-chairman" "CARDANO_NODE_CHAIRMAN" . ("run":) +procChairman = GHC.withFrozenCallStack $ H.evalM . H.procFlex "cardano-node-chairman" "CARDANO_NODE_CHAIRMAN" . ("run":) mkExecConfig :: () => MonadTest m @@ -236,119 +226,3 @@ resourceAndIOExceptionHandlers = [ Handler $ pure . ProcessIOException , Handler $ pure . ResourceException ] -procFlexNew - :: MonadIO m - => String - -- ^ Cabal package name corresponding to the executable - -> String - -- ^ Environment variable pointing to the binary to run - -> [String] - -- ^ Arguments to the CLI command - -> ExceptT ExecutableError m CreateProcess - -- ^ Captured stdout -procFlexNew = procFlexNew' H.defaultExecConfig - -procFlexNew' - :: MonadIO m - => H.ExecConfig - -> String - -- ^ Cabal package name corresponding to the executable - -> String - -- ^ Environment variable pointing to the binary to run - -> [String] - -- ^ Arguments to the CLI command - -> ExceptT ExecutableError m CreateProcess - -- ^ Captured stdout -procFlexNew' execConfig pkg binaryEnv arguments = GHC.withFrozenCallStack $ do - bin <- binFlexNew pkg binaryEnv - pure (IO.proc bin arguments) - { IO.env = getLast $ H.execConfigEnv execConfig - , IO.cwd = getLast $ H.execConfigCwd execConfig - -- this allows sending signals to the created processes, without killing the test-suite process - , IO.create_group = True - } - --- | Compute the path to the binary given a package name or an environment variable override. -binFlexNew - :: MonadIO m - => String - -- ^ Package name - -> String - -- ^ Environment variable pointing to the binary to run - -> ExceptT ExecutableError m FilePath - -- ^ Path to executable -binFlexNew pkg binaryEnv = do - maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv - case maybeEnvBin of - Just envBin -> return envBin - Nothing -> binDist pkg - --- | Find the nearest plan.json going upwards from the current directory. -findDefaultPlanJsonFile :: IO FilePath -findDefaultPlanJsonFile = IO.getCurrentDirectory >>= go - where go :: FilePath -> IO FilePath - go d = do - let file = d "dist-newstyle/cache/plan.json" - exists <- IO.doesFileExist file - if exists - then return file - else do - let parent = takeDirectory d - if parent == d - then return "dist-newstyle/cache/plan.json" - else go parent - - --- | Discover the location of the plan.json file. -planJsonFile :: IO FilePath -planJsonFile = do - maybeBuildDir <- liftIO $ IO.lookupEnv "CABAL_BUILDDIR" - case maybeBuildDir of - Just buildDir -> return $ ".." buildDir "cache/plan.json" - Nothing -> findDefaultPlanJsonFile -{-# NOINLINE planJsonFile #-} - -data ExecutableError - = CannotDecodePlanJSON FilePath String - | RetrievePlanJsonFailure IOException - | ReadFileFailure IOException - | ExecutableMissingInComponent FilePath String - -- ^ Component with key @component-name@ is found, but it is missing - -- the @bin-file@ key. - | ExecutableNotFoundInPlan String - -- ^ Component with key @component-name@ cannot be found - deriving Show - - --- | Consult the "plan.json" generated by cabal to get the path to the executable corresponding. --- to a haskell package. It is assumed that the project has already been configured and the --- executable has been built. -binDist - :: MonadIO m - => String - -- ^ Package name - -> ExceptT ExecutableError m FilePath - -- ^ Path to executable -binDist pkg = do - pJsonFp <- handleIOExceptT RetrievePlanJsonFailure planJsonFile - contents <- handleIOExceptT ReadFileFailure $ LBS.readFile pJsonFp - - case Aeson.eitherDecode contents of - Right plan -> case List.filter matching (plan & installPlan) of - (component:_) -> case component & binFile of - Just bin -> return $ addExeSuffix (Text.unpack bin) - Nothing -> left $ ExecutableMissingInComponent pJsonFp $ "missing \"bin-file\" key in plan component: " <> show component - [] -> left $ ExecutableNotFoundInPlan $ "Cannot find \"component-name\" key with value \"exe:" <> pkg <> "\"" - Left message -> left $ CannotDecodePlanJSON pJsonFp $ "Cannot decode plan: " <> message - where matching :: Component -> Bool - matching component = case componentName component of - Just name -> name == Text.pack ("exe:" <> pkg) - Nothing -> False - -addExeSuffix :: String -> String -addExeSuffix s = if ".exe" `List.isSuffixOf` s - then s - else s <> exeSuffix - -exeSuffix :: String -exeSuffix = if OS.isWin32 then ".exe" else "" diff --git a/cardano-testnet/src/Testnet/Property/Util.hs b/cardano-testnet/src/Testnet/Property/Util.hs index 4453ed9dbcd..9db518d81c7 100644 --- a/cardano-testnet/src/Testnet/Property/Util.hs +++ b/cardano-testnet/src/Testnet/Property/Util.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,23 +15,14 @@ module Testnet.Property.Util import Cardano.Api -import Control.Exception.Safe -import Control.Monad -import Control.Monad.Trans.Resource -import qualified Control.Retry as R import qualified Data.Aeson as Aeson import GHC.Stack -import qualified System.Directory as IO import qualified System.Environment as IO -import System.FilePath (()) import System.Info (os) -import qualified System.IO as IO -import qualified System.IO.Temp as IO import qualified System.IO.Unsafe as IO import qualified Hedgehog as H import qualified Hedgehog.Extras as H -import qualified Hedgehog.Extras.Stock.CallStack as H import Hedgehog.Internal.Property (MonadTest) @@ -53,52 +43,16 @@ integrationRetryWorkspace n workspaceName f = withFrozenCallStack $ if disableRetries then integration $ - H.runFinallies $ workspace (workspaceName <> "-no-retries") f + H.runFinallies $ H.workspace (workspaceName <> "-no-retries") f else integration $ H.retry n $ \i -> - H.runFinallies $ workspace (workspaceName <> "-" <> show i) f - --- | Create a workspace directory which will exist for at least the duration of --- the supplied block. --- --- The directory will have the supplied prefix but contain a generated random --- suffix to prevent interference between tests --- --- The directory will be deleted if the block succeeds, but left behind if --- the block fails. --- TODO: this is a version which retries deleting of a workspace on exception - upstream to hedgehog-extras -workspace - :: MonadTest m - => HasCallStack - => MonadResource m - => FilePath - -> (FilePath -> m ()) - -> m () -workspace prefixPath f = withFrozenCallStack $ do - systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory - maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE" - ws <- H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test" - H.annotate $ "Workspace: " <> ws - H.evalIO $ IO.writeFile (ws "module") H.callerModuleName - f ws - when (os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do - -- try to delete the directory 5 times, 100ms apart - let retryPolicy = R.constantDelay 100_000 <> R.limitRetries 10 - -- retry only on IOExceptions - ioExH _ = Handler $ \(_ :: IOException) -> pure True - -- For some reason, the temporary directory removal sometimes fails. - -- Lets wrap this in MonadResource try multiple times before we fail. - void - . register - . R.recovering retryPolicy [ioExH] - . const - $ IO.removePathForcibly ws + H.runFinallies $ H.workspace (workspaceName <> "-" <> show i) f -- | The 'FilePath' in '(FilePath -> H.Integration ())' is the work space directory. -- This is created (and returned) via 'H.workspace'. integrationWorkspace :: HasCallStack => FilePath -> (FilePath -> H.Integration ()) -> H.Property integrationWorkspace workspaceName f = withFrozenCallStack $ - integration $ H.runFinallies $ workspace workspaceName f + integration $ H.runFinallies $ H.workspace workspaceName f isLinux :: Bool isLinux = os == "linux" diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index e4471a773e8..b11b726cdb7 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -60,7 +60,7 @@ import qualified Hedgehog.Extras.Test.Concurrent as H data NodeStartFailure = ProcessRelatedFailure ProcessError - | ExecutableRelatedFailure ExecutableError + | ExecutableRelatedFailure SomeException | FileRelatedFailure IOException | NodeExecutableError (Doc Ann) | NodeAddressAlreadyInUseError (Doc Ann) @@ -143,8 +143,8 @@ startNode tp node ipv4 port testnetMagic nodeCmd = GHC.withFrozenCallStack $ do let socketAbsPath = H.sprocketSystemName sprocket nodeProcess - <- firstExceptT ExecutableRelatedFailure - $ hoistExceptT liftIO $ procNode $ mconcat + <- newExceptT . fmap (first ExecutableRelatedFailure) . try + $ procNode $ mconcat [ nodeCmd , [ "--socket-path", H.sprocketArgumentName sprocket , "--port", show port diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs index bf96df3a827..ba2d3d91943 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Node/Shutdown.hs @@ -141,17 +141,16 @@ hprop_shutdown = integrationRetryWorkspace 2 "shutdown" $ \tempAbsBasePath' -> H -- Run cardano-node with pipe as stdin. Use 0 file descriptor as shutdown-ipc - eRes <- H.evalIO . runExceptT $ procNode - [ "run" - , "--config", tempAbsPath' "configuration.yaml" - , "--topology", tempAbsPath' "mainnet-topology.json" - , "--database-path", tempAbsPath' "db" - , "--socket-path", IO.sprocketArgumentName sprocket - , "--host-addr", "127.0.0.1" - , "--port", show @Int port - , "--shutdown-ipc", "0" - ] - res <- H.evalEither eRes + res <- H.evalM $ procNode + [ "run" + , "--config", tempAbsPath' "configuration.yaml" + , "--topology", tempAbsPath' "mainnet-topology.json" + , "--database-path", tempAbsPath' "db" + , "--socket-path", IO.sprocketArgumentName sprocket + , "--host-addr", "127.0.0.1" + , "--port", show @Int port + , "--shutdown-ipc", "0" + ] let process = res { IO.std_in = IO.CreatePipe , IO.std_out = IO.UseHandle hNodeStdout , IO.std_err = IO.UseHandle hNodeStderr