Remove redundant functions used for starting a process

IntersectMBO · Oct 15, 2024 · 86609ef · 86609ef
1 parent b0d8411
commit 86609ef
Show file tree

Hide file tree

Showing 4 changed files with 28 additions and 201 deletions.
diff --git 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,28 +29,20 @@ 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
 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,22 +64,22 @@ 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'
   :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
   => 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,15 +89,15 @@ 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
   :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
   => [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
@@ -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
@@ -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
@@ -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