diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal index 74b84ebd..626d846c 100644 --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -19,6 +19,7 @@ source-repository head common aeson { build-depends: aeson >= 2.0.0.0 && < 2.3 } common aeson-pretty { build-depends: aeson-pretty >= 0.8.5 && < 0.9 } +common annotated-exception { build-depends: annotated-exception < 0.4 } common async { build-depends: async < 2.3 } common base { build-depends: base >= 4.12 && < 4.22 } common bytestring { build-depends: bytestring < 0.13 } @@ -76,6 +77,7 @@ library import: base, project-config, aeson-pretty, aeson, + annotated-exception, async, bytestring, containers, @@ -118,6 +120,7 @@ library Hedgehog.Extras.Internal.Cli Hedgehog.Extras.Internal.Orphans Hedgehog.Extras.Internal.Plan + Hedgehog.Extras.Internal.Process Hedgehog.Extras.Internal.Test.Integration Hedgehog.Extras.Stock Hedgehog.Extras.Stock.Aeson @@ -141,6 +144,7 @@ library Hedgehog.Extras.Test.Network Hedgehog.Extras.Test.Prim Hedgehog.Extras.Test.Process + Hedgehog.Extras.Test.ProcessIO Hedgehog.Extras.Test.TestWatchdog Hedgehog.Extras.Test.Tripwire Hedgehog.Extras.Test.Unit diff --git a/src/Hedgehog/Extras/Internal/Process.hs b/src/Hedgehog/Extras/Internal/Process.hs new file mode 100644 index 00000000..403f5bdb --- /dev/null +++ b/src/Hedgehog/Extras/Internal/Process.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hedgehog.Extras.Internal.Process + ( binDist + , liftIOAnnotated + , planJsonFile + ) where + +import Control.Applicative (pure, (<|>)) +import Control.Exception.Annotated (exceptionWithCallStack) +import Control.Monad (Monad (..), unless) +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (eitherDecode) +import Data.Bool (otherwise) +import Data.Either (Either (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Maybe (Maybe (..)) +import Data.Monoid ((<>)) +import Data.String (IsString (..), String) +import GHC.Stack (HasCallStack) +import Hedgehog.Extras.Internal.Plan (Component (..), Plan (..)) +import Prelude (error) +import System.FilePath (takeDirectory) +import System.FilePath.Posix (()) +import System.IO (FilePath, IO) +import Text.Show (Show (show)) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as L +import Data.Text (Text) +import qualified Data.Text as T +import qualified GHC.Stack as GHC +import qualified Hedgehog.Extras.Stock.OS as OS +import qualified System.Directory as IO +import qualified System.Environment as IO +import qualified System.IO.Unsafe as IO + +-- | 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. +-- Throws an exception on failure. +binDist + :: (HasCallStack, MonadIO m) + => String + -- ^ Package name + -> String + -- ^ Environment variable pointing to the binary to run (used for error messages only) + -> m FilePath + -- ^ Path to executable +binDist pkg binaryEnv = do + doesPlanExist <- liftIOAnnotated $ IO.doesFileExist planJsonFile + unless doesPlanExist $ + error $ "Could not find plan.json in the path: " + <> planJsonFile + <> ". Please run \"cabal build " + <> pkg + <> "\" if you are working with sources. Otherwise define " + <> binaryEnv + <> " and have it point to the executable you want." + + Plan{installPlan} <- eitherDecode <$> liftIOAnnotated (LBS.readFile planJsonFile) + >>= \case + Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message + Right plan -> pure plan + + let componentName = "exe:" <> fromString pkg + case findComponent componentName installPlan of + Just Component{binFile=Just binFilePath} -> pure . addExeSuffix $ T.unpack binFilePath + Just component@Component{binFile=Nothing} -> + error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile + Nothing -> + error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile + where + findComponent :: Text -> [Component] -> Maybe Component + findComponent _ [] = Nothing + findComponent needle (c@Component{componentName, components}:topLevelComponents) + | componentName == Just needle = Just c + | otherwise = findComponent needle topLevelComponents <|> findComponent needle components + +-- This will also catch async exceptions as well. +liftIOAnnotated :: (HasCallStack, MonadIO m) => IO a -> m a +liftIOAnnotated action = GHC.withFrozenCallStack $ + liftIO $ action `catch` (\(e :: SomeException) -> throwM $ exceptionWithCallStack e) + +-- | Discover the location of the plan.json file. +planJsonFile :: String +planJsonFile = IO.unsafePerformIO $ do + maybeBuildDir <- liftIOAnnotated $ IO.lookupEnv "CABAL_BUILDDIR" + case maybeBuildDir of + Just buildDir -> return $ ".." buildDir "cache/plan.json" + Nothing -> findDefaultPlanJsonFile +{-# NOINLINE planJsonFile #-} + +-- | 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 planRelPath = "dist-newstyle/cache/plan.json" + file = d planRelPath + exists <- IO.doesFileExist file + if exists + then return file + else do + let parent = takeDirectory d + if parent == d + then return planRelPath + else go parent + +addExeSuffix :: String -> String +addExeSuffix s = if ".exe" `L.isSuffixOf` s + then s + else s <> exeSuffix + + +exeSuffix :: String +exeSuffix = if OS.isWin32 then ".exe" else "" diff --git a/src/Hedgehog/Extras/Test/Concurrent.hs b/src/Hedgehog/Extras/Test/Concurrent.hs index 1949c5ed..ce466d0f 100644 --- a/src/Hedgehog/Extras/Test/Concurrent.hs +++ b/src/Hedgehog/Extras/Test/Concurrent.hs @@ -60,33 +60,32 @@ Please note that only @FAIL1@ and @FAIL2@ annotations were reported - @FAIL3@ an below was swallowed without any information. __Don't use concurrency abstractions from this module, when you need to aggregate and report failures!__ - -} -module Hedgehog.Extras.Test.Concurrent - ( threadDelay - , asyncRegister_ - -- * Re-exports of concurrency abstractions from @lifted-base@ - , module Control.Concurrent.Async.Lifted - , module Control.Concurrent.MVar.Lifted - , module System.Timeout.Lifted - ) where +module Hedgehog.Extras.Test.Concurrent ( + threadDelay, + asyncRegister_, + + -- * Re-exports of concurrency abstractions from @lifted-base@ + module Control.Concurrent.Async.Lifted, + module Control.Concurrent.MVar.Lifted, + module System.Timeout.Lifted, +) where -import Control.Concurrent.Async.Lifted +import Control.Concurrent.Async.Lifted import qualified Control.Concurrent.Lifted as IO -import Control.Concurrent.MVar.Lifted -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Function -import Data.Int +import Control.Concurrent.MVar.Lifted +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Function +import Data.Int import qualified GHC.Stack as GHC -import System.IO (IO) -import System.Timeout.Lifted -import Hedgehog.Extras.Internal.Orphans () +import Hedgehog.Extras.Internal.Orphans () +import System.IO (IO) +import System.Timeout.Lifted -import Control.Monad -import Control.Monad.Catch (MonadCatch) -import GHC.Stack -import Hedgehog +import Control.Monad +import GHC.Stack +import Hedgehog import qualified Hedgehog as H -- | Delay the thread by 'n' microseconds. @@ -94,13 +93,20 @@ threadDelay :: (HasCallStack, MonadTest m, MonadIO m) => Int -> m () threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n -- | Runs an action in background, and registers its cancellation to 'MonadResource'. -asyncRegister_ :: HasCallStack - => MonadTest m - => MonadResource m - => MonadCatch m - => IO a -- ^ Action to run in background - -> m () -asyncRegister_ act = GHC.withFrozenCallStack $ void . H.evalM $ allocate (async act) cleanUp +asyncRegister_ :: + (HasCallStack) => + (MonadResource m) => + -- | Action to run in background + IO a -> + m (ReleaseKey, Async a) +asyncRegister_ act = GHC.withFrozenCallStack $ do + allocate + ( do + a <- async act + link a + return a + ) + cleanUp where cleanUp :: Async a -> IO () - cleanUp a = cancel a >> void (link a) + cleanUp = cancel diff --git a/src/Hedgehog/Extras/Test/Process.hs b/src/Hedgehog/Extras/Test/Process.hs index 8d38435f..e9028530 100644 --- a/src/Hedgehog/Extras/Test/Process.hs +++ b/src/Hedgehog/Extras/Test/Process.hs @@ -1,397 +1,332 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Hedgehog.Extras.Test.Process - ( createProcess - , exec - , execAny - , exec_ - , execFlex - , execFlex' - , execFlexAny' - , procFlex - , binFlex +module Hedgehog.Extras.Test.Process ( + createProcess, + exec, + execAny, + exec_, + execFlex, + execFlex', + execFlexAny', + procFlex, + binFlex, + getProjectBase, + waitForProcess, + maybeWaitForProcess, + getPid, + getPidOk, + waitSecondsForProcess, + ExecConfig (..), + defaultExecConfig, +) where + +import Control.Monad (Monad (..), MonadFail (fail), void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register) +import Data.Bool (Bool (True)) +import Data.Either (Either (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Int (Int) +import Data.Maybe (Maybe (..)) +import Data.Monoid (Last (..), mempty, (<>)) +import Data.String (String) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import Hedgehog (MonadTest) +import Hedgehog.Extras.Internal.Cli (argQuote) +import qualified Hedgehog.Extras.Internal.Process as Internal +import Hedgehog.Extras.Stock.IO.Process (TimedOut (..)) +import System.Exit (ExitCode) +import System.FilePath.Posix (()) +import System.IO (FilePath, Handle) +import System.Process (CmdSpec (..), CreateProcess (..), Pid, ProcessHandle) +import Text.Show (Show (show)) +import Prelude ((++)) - , getProjectBase - , waitForProcess - , maybeWaitForProcess - , getPid - , getPidOk - , waitSecondsForProcess - - , ExecConfig(..) - , defaultExecConfig - ) where - -import Control.Applicative (pure, (<|>)) -import Control.Monad (Monad (..), MonadFail (fail), unless, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register) -import Data.Aeson (eitherDecode) -import Data.Bool (Bool (True), otherwise) -import Data.Either (Either (..)) -import Data.Eq (Eq (..)) -import Data.Function (($), (.)) -import Data.Functor ((<$>)) -import Data.Int (Int) -import Data.Maybe (Maybe (..)) -import Data.Monoid (Last (..), mempty, (<>)) -import Data.String (IsString (..), String) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import Hedgehog (MonadTest) -import Hedgehog.Extras.Internal.Cli (argQuote) -import Hedgehog.Extras.Internal.Plan (Component (..), Plan (..)) -import Hedgehog.Extras.Stock.IO.Process (TimedOut (..)) -import Prelude (error, (++)) -import System.Exit (ExitCode) -import System.FilePath (takeDirectory) -import System.FilePath.Posix (()) -import System.IO (FilePath, Handle, IO) -import System.Process (CmdSpec (..), CreateProcess (..), Pid, ProcessHandle) -import Text.Show (Show (show)) - -import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L -import Data.Text (Text) -import qualified Data.Text as T import qualified GHC.Stack as GHC import qualified Hedgehog as H import qualified Hedgehog.Extras.Stock.IO.Process as IO -import qualified Hedgehog.Extras.Stock.OS as OS import qualified Hedgehog.Extras.Test.Base as H import qualified System.Directory as IO import qualified System.Environment as IO import qualified System.Exit as IO -import qualified System.IO.Unsafe as IO import qualified System.Process as IO -- | Configuration for starting a new process. This is a subset of 'IO.CreateProcess'. data ExecConfig = ExecConfig - { execConfigEnv :: Last [(String, String)] - , execConfigCwd :: Last FilePath - } deriving (Eq, Generic, Show) + { execConfigEnv :: Last [(String, String)] + , execConfigCwd :: Last FilePath + } + deriving (Eq, Generic, Show) defaultExecConfig :: ExecConfig -defaultExecConfig = ExecConfig - { execConfigEnv = mempty - , execConfigCwd = mempty - } - --- | 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 planRelPath = "dist-newstyle/cache/plan.json" - file = d planRelPath - exists <- IO.doesFileExist file - if exists - then return file - else do - let parent = takeDirectory d - if parent == d - then return planRelPath - else go parent - --- | Discover the location of the plan.json file. -planJsonFile :: String -planJsonFile = IO.unsafePerformIO $ do - maybeBuildDir <- liftIO $ IO.lookupEnv "CABAL_BUILDDIR" - case maybeBuildDir of - Just buildDir -> return $ ".." buildDir "cache/plan.json" - Nothing -> findDefaultPlanJsonFile -{-# NOINLINE planJsonFile #-} - -exeSuffix :: String -exeSuffix = if OS.isWin32 then ".exe" else "" - -addExeSuffix :: String -> String -addExeSuffix s = if ".exe" `L.isSuffixOf` s - then s - else s <> exeSuffix +defaultExecConfig = + ExecConfig + { execConfigEnv = mempty + , execConfigCwd = mempty + } -- | Create a process returning handles to stdin, stdout, and stderr as well as the process handle. -createProcess - :: (MonadTest m, MonadResource m, HasCallStack) - => CreateProcess - -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle, ReleaseKey) +createProcess :: + (MonadTest m, MonadResource m, HasCallStack) => + CreateProcess -> + m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle, ReleaseKey) createProcess cp = GHC.withFrozenCallStack $ do - H.annotate $ "CWD: " <> show (IO.cwd cp) - case IO.cmdspec cp of - RawCommand cmd args -> H.annotate $ "Command line: " <> cmd <> " " <> L.unwords args - ShellCommand cmd -> H.annotate $ "Command line: " <> cmd - (mhStdin, mhStdout, mhStderr, hProcess) <- H.evalIO $ IO.createProcess cp - releaseKey <- register $ IO.cleanupProcess (mhStdin, mhStdout, mhStderr, hProcess) + H.annotate $ "CWD: " <> show (IO.cwd cp) + case IO.cmdspec cp of + RawCommand cmd args -> H.annotate $ "Command line: " <> cmd <> " " <> L.unwords args + ShellCommand cmd -> H.annotate $ "Command line: " <> cmd + (mhStdin, mhStdout, mhStderr, hProcess) <- H.evalIO $ IO.createProcess cp + releaseKey <- register $ IO.cleanupProcess (mhStdin, mhStdout, mhStderr, hProcess) - return (mhStdin, mhStdout, mhStderr, hProcess, releaseKey) + return (mhStdin, mhStdout, mhStderr, hProcess, releaseKey) -- | Get the process ID. -getPid - :: (MonadTest m, MonadIO m, HasCallStack) - => ProcessHandle - -> m (Maybe Pid) +getPid :: + (MonadTest m, MonadIO m, HasCallStack) => + ProcessHandle -> + m (Maybe Pid) getPid hProcess = GHC.withFrozenCallStack . H.evalIO $ IO.getPid hProcess -- | Get the process ID. -getPidOk - :: (MonadTest m, MonadIO m, HasCallStack) - => ProcessHandle - -> m Pid -getPidOk hProcess = GHC.withFrozenCallStack $ - H.nothingFailM $ getPid hProcess - --- | Create a process returning its stdout. --- --- Being a 'flex' function means that the environment determines how the process is launched. --- --- When running in a nix environment, the 'envBin' argument describes the environment variable --- that defines the binary to use to launch the process. --- --- When running outside a nix environment, the `pkgBin` describes the name of the binary --- to launch via cabal exec. -execFlex - :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) - => String - -> String - -> [String] - -> m String +getPidOk :: + (MonadTest m, MonadIO m, HasCallStack) => + ProcessHandle -> + m Pid +getPidOk hProcess = + GHC.withFrozenCallStack $ + H.nothingFailM $ + getPid hProcess + +{- | Create a process returning its stdout. + +Being a 'flex' function means that the environment determines how the process is launched. + +When running in a nix environment, the 'envBin' argument describes the environment variable +that defines the binary to use to launch the process. + +When running outside a nix environment, the `pkgBin` describes the name of the binary +to launch via cabal exec. +-} +execFlex :: + (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => + String -> + String -> + [String] -> + m String execFlex = execFlex' defaultExecConfig -execFlex' - :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) - => ExecConfig - -> String - -> String - -> [String] - -> m String +execFlex' :: + (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => + ExecConfig -> + String -> + String -> + [String] -> + m String execFlex' execConfig pkgBin envBin arguments = GHC.withFrozenCallStack $ do - (exitResult, stdout, stderr) <- execFlexAny' execConfig pkgBin envBin arguments - case exitResult of - IO.ExitFailure exitCode -> do - H.annotate $ L.unlines $ - [ "Process exited with non-zero exit-code: " ++ show @Int exitCode ] - ++ (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout]) - ++ (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr]) - H.failMessage GHC.callStack "Execute process failed" - IO.ExitSuccess -> return stdout - --- | Run a process, returning its exit code, its stdout, and its stderr. --- Contrary to @execFlex'@, this function doesn't fail if the call fails. --- So, if you want to test something negative, this is the function to use. -execFlexAny' - :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) - => ExecConfig - -> String -- ^ @pkgBin@: name of the binary to launch via 'cabal exec' - -> String -- ^ @envBin@: environment variable defining the binary to launch the process, when in Nix - -> [String] - -> m (ExitCode, String, String) -- ^ exit code, stdout, stderr + (exitResult, stdout, stderr) <- execFlexAny' execConfig pkgBin envBin arguments + case exitResult of + IO.ExitFailure exitCode -> do + H.annotate $ + L.unlines $ + ["Process exited with non-zero exit-code: " ++ show @Int exitCode] + ++ (if L.null stdout then [] else ["━━━━ stdout ━━━━", stdout]) + ++ (if L.null stderr then [] else ["━━━━ stderr ━━━━", stderr]) + H.failMessage GHC.callStack "Execute process failed" + IO.ExitSuccess -> return stdout + +{- | Run a process, returning its exit code, its stdout, and its stderr. +Contrary to @execFlex'@, this function doesn't fail if the call fails. +So, if you want to test something negative, this is the function to use. +-} +execFlexAny' :: + (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => + ExecConfig -> + -- | @pkgBin@: name of the binary to launch via 'cabal exec' + String -> + -- | @envBin@: environment variable defining the binary to launch the process, when in Nix + String -> + [String] -> + -- | exit code, stdout, stderr + m (ExitCode, String, String) execFlexAny' execConfig pkgBin envBin arguments = GHC.withFrozenCallStack $ do - cp <- procFlex' execConfig pkgBin envBin arguments - H.annotate . ("━━━━ command ━━━━\n" <>) $ case IO.cmdspec cp of - IO.ShellCommand cmd -> cmd - IO.RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args) - H.evalIO $ IO.readCreateProcessWithExitCode cp "" + cp <- procFlex' execConfig pkgBin envBin arguments + H.annotate . ("━━━━ command ━━━━\n" <>) $ case IO.cmdspec cp of + IO.ShellCommand cmd -> cmd + IO.RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args) + H.evalIO $ IO.readCreateProcessWithExitCode cp "" -- | Execute a process, returning '()'. -exec_ - :: (MonadTest m, MonadIO m, HasCallStack) - => ExecConfig - -> String - -> [String] - -> m () +exec_ :: + (MonadTest m, MonadIO m, HasCallStack) => + ExecConfig -> + String -> + [String] -> + m () exec_ execConfig bin arguments = void $ exec execConfig bin arguments --- | Execute a process, returning the stdout. Fail if the call returns --- with a non-zero exit code. For a version that doesn't fail upon receiving --- a non-zero exit code, see 'execAny'. -exec - :: (MonadTest m, MonadIO m, HasCallStack) - => ExecConfig - -> String - -> [String] - -> m String +{- | Execute a process, returning the stdout. Fail if the call returns +with a non-zero exit code. For a version that doesn't fail upon receiving +a non-zero exit code, see 'execAny'. +-} +exec :: + (MonadTest m, MonadIO m, HasCallStack) => + ExecConfig -> + String -> + [String] -> + m String exec execConfig bin arguments = GHC.withFrozenCallStack $ do - (exitResult, stdout, stderr) <- execAny execConfig bin arguments - case exitResult of - IO.ExitFailure exitCode -> H.failMessage GHC.callStack . L.unlines $ - [ "Process exited with non-zero exit-code: " ++ show @Int exitCode ] - ++ (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout]) - ++ (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr]) - IO.ExitSuccess -> return stdout + (exitResult, stdout, stderr) <- execAny execConfig bin arguments + case exitResult of + IO.ExitFailure exitCode -> + H.failMessage GHC.callStack . L.unlines $ + ["Process exited with non-zero exit-code: " ++ show @Int exitCode] + ++ (if L.null stdout then [] else ["━━━━ stdout ━━━━", stdout]) + ++ (if L.null stderr then [] else ["━━━━ stderr ━━━━", stderr]) + IO.ExitSuccess -> return stdout -- | Execute a process, returning the error code, the stdout, and the stderr. -execAny - :: (MonadTest m, MonadIO m, HasCallStack) - => ExecConfig - -> String -- ^ The binary to launch - -> [String] -- ^ The binary's arguments - -> m (ExitCode, String, String) -- ^ exit code, stdout, stderr +execAny :: + (MonadTest m, MonadIO m, HasCallStack) => + ExecConfig -> + -- | The binary to launch + String -> + -- | The binary's arguments + [String] -> + -- | exit code, stdout, stderr + m (ExitCode, String, String) execAny execConfig bin arguments = GHC.withFrozenCallStack $ do - let cp = (IO.proc bin arguments) - { IO.env = getLast $ execConfigEnv execConfig - , IO.cwd = getLast $ execConfigCwd execConfig - } - H.annotate . ( "━━━━ command ━━━━\n" <>) $ bin <> " " <> L.unwords (argQuote <$> arguments) - H.evalIO $ IO.readCreateProcessWithExitCode cp "" + let cp = + (IO.proc bin arguments) + { IO.env = getLast $ execConfigEnv execConfig + , IO.cwd = getLast $ execConfigCwd execConfig + } + H.annotate . ("━━━━ command ━━━━\n" <>) $ bin <> " " <> L.unwords (argQuote <$> arguments) + H.evalIO $ IO.readCreateProcessWithExitCode cp "" -- | Wait for process to exit. -waitForProcess - :: (MonadTest m, MonadIO m, HasCallStack) - => ProcessHandle - -> m ExitCode -waitForProcess hProcess = GHC.withFrozenCallStack $ - H.evalIO $ IO.waitForProcess hProcess +waitForProcess :: + (MonadTest m, MonadIO m, HasCallStack) => + ProcessHandle -> + m ExitCode +waitForProcess hProcess = + GHC.withFrozenCallStack $ + H.evalIO $ + IO.waitForProcess hProcess -- | Wait for process to exit or return 'Nothing' if interrupted by an asynchronous exception. -maybeWaitForProcess - :: (MonadTest m, MonadIO m, HasCallStack) - => ProcessHandle - -> m (Maybe ExitCode) -maybeWaitForProcess hProcess = GHC.withFrozenCallStack $ - H.evalIO $ IO.maybeWaitForProcess hProcess +maybeWaitForProcess :: + (MonadTest m, MonadIO m, HasCallStack) => + ProcessHandle -> + m (Maybe ExitCode) +maybeWaitForProcess hProcess = + GHC.withFrozenCallStack $ + H.evalIO $ + IO.maybeWaitForProcess hProcess -- | Wait a maximum of 'seconds' secons for process to exit. -waitSecondsForProcess - :: (MonadTest m, MonadIO m, HasCallStack) - => Int - -> ProcessHandle - -> m (Either TimedOut ExitCode) +waitSecondsForProcess :: + (MonadTest m, MonadIO m, HasCallStack) => + Int -> + ProcessHandle -> + m (Either TimedOut ExitCode) waitSecondsForProcess seconds hProcess = GHC.withFrozenCallStack $ do - result <- H.evalIO $ IO.waitSecondsForProcess seconds hProcess - case result of - Left TimedOut -> do - H.annotate "Timed out waiting for process to exit" - return (Left TimedOut) - Right maybeExitCode -> do - case maybeExitCode of - Nothing -> H.failMessage GHC.callStack "No exit code for process" - Just exitCode -> do - H.annotate $ "Process exited " <> show exitCode - return (Right exitCode) + result <- H.evalIO $ IO.waitSecondsForProcess seconds hProcess + case result of + Left TimedOut -> do + H.annotate "Timed out waiting for process to exit" + return (Left TimedOut) + Right maybeExitCode -> do + case maybeExitCode of + Nothing -> H.failMessage GHC.callStack "No exit code for process" + Just exitCode -> do + H.annotate $ "Process exited " <> show exitCode + return (Right exitCode) -- | Compute the path to the binary given a package name or an environment variable override. -binFlex - :: (HasCallStack, MonadTest m, MonadIO m) - => String - -- ^ Package name - -> String - -- ^ Environment variable pointing to the binary to run - -> m FilePath - -- ^ Path to executable +binFlex :: + (HasCallStack, MonadTest m, MonadIO m) => + -- | Package name + String -> + -- | Environment variable pointing to the binary to run + String -> + -- | Path to executable + m FilePath binFlex pkg binaryEnv = do - maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv - case maybeEnvBin of - Just envBin -> return envBin - Nothing -> binDist pkg binaryEnv - --- | 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. --- Throws an exception on failure. -binDist - :: (HasCallStack, MonadTest m, MonadIO m) - => String - -- ^ Package name - -> String - -- ^ Environment variable pointing to the binary to run (used for error messages only) - -> m FilePath - -- ^ Path to executable -binDist pkg binaryEnv = do - doesPlanExist <- liftIO $ IO.doesFileExist planJsonFile - unless doesPlanExist $ - error $ "Could not find plan.json in the path: " - <> planJsonFile - <> ". Please run \"cabal build " - <> pkg - <> "\" if you are working with sources. Otherwise define " - <> binaryEnv - <> " and have it point to the executable you want." - - Plan{installPlan} <- eitherDecode <$> H.evalIO (LBS.readFile planJsonFile) - >>= \case - Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message - Right plan -> pure plan - - let componentName = "exe:" <> fromString pkg - case findComponent componentName installPlan of - Just Component{binFile=Just binFilePath} -> pure . addExeSuffix $ T.unpack binFilePath - Just component@Component{binFile=Nothing} -> - error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile - Nothing -> - error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile - where - findComponent :: Text -> [Component] -> Maybe Component - findComponent _ [] = Nothing - findComponent needle (c@Component{componentName, components}:topLevelComponents) - | componentName == Just needle = Just c - | otherwise = findComponent needle topLevelComponents <|> findComponent needle components - - --- | Create a 'CreateProcess' describing how to start a process given the Cabal package name --- corresponding to the executable, an environment variable pointing to the executable, --- and an argument list. --- --- The actual executable used will the one specified by the environment variable, but if --- the environment variable is not defined, it will be found instead by consulting the --- "plan.json" generated by cabal. It is assumed that the project has already been --- configured and the executable has been built. -procFlex - :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) - => String - -- ^ Cabal package name corresponding to the executable - -> String - -- ^ Environment variable pointing to the binary to run - -> [String] - -- ^ Arguments to the CLI command - -> m CreateProcess - -- ^ Captured stdout + maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv + case maybeEnvBin of + Just envBin -> return envBin + Nothing -> Internal.binDist pkg binaryEnv + +{- | Create a 'CreateProcess' describing how to start a process given the Cabal package name +corresponding to the executable, an environment variable pointing to the executable, +and an argument list. + +The actual executable used will the one specified by the environment variable, but if +the environment variable is not defined, it will be found instead by consulting the +"plan.json" generated by cabal. It is assumed that the project has already been +configured and the executable has been built. +-} +procFlex :: + (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => + -- | Cabal package name corresponding to the executable + String -> + -- | Environment variable pointing to the binary to run + String -> + -- | Arguments to the CLI command + [String] -> + -- | Captured stdout + m CreateProcess procFlex = procFlex' defaultExecConfig -procFlex' - :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) - => ExecConfig - -> String - -- ^ Cabal package name corresponding to the executable - -> String - -- ^ Environment variable pointing to the binary to run - -> [String] - -- ^ Arguments to the CLI command - -> m CreateProcess - -- ^ Captured stdout +procFlex' :: + (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) => + ExecConfig -> + -- | Cabal package name corresponding to the executable + String -> + -- | Environment variable pointing to the binary to run + String -> + -- | Arguments to the CLI command + [String] -> + -- | Captured stdout + m CreateProcess procFlex' execConfig pkg binaryEnv arguments = GHC.withFrozenCallStack . H.evalM $ do - bin <- binFlex pkg binaryEnv - return (IO.proc bin arguments) - { IO.env = getLast $ execConfigEnv execConfig - , IO.cwd = getLast $ execConfigCwd execConfig - -- this allows sending signals to the created processes, without killing the test-suite process - , IO.create_group = True - } - --- | Compute the project base. This will be based on either the "CARDANO_NODE_SRC" --- environment variable or the first parent directory that contains the `cabal.project`. --- Both should point to the root directory of the Github project checkout. -getProjectBase - :: (MonadTest m, MonadIO m) - => m String + bin <- binFlex pkg binaryEnv + return + (IO.proc bin arguments) + { IO.env = getLast $ execConfigEnv execConfig + , IO.cwd = getLast $ execConfigCwd execConfig + , -- this allows sending signals to the created processes, without killing the test-suite process + IO.create_group = True + } + +{- | Compute the project base. This will be based on either the "CARDANO_NODE_SRC" +environment variable or the first parent directory that contains the `cabal.project`. +Both should point to the root directory of the Github project checkout. +-} +getProjectBase :: + (MonadTest m, MonadIO m) => + m String getProjectBase = do - let - findUp dir = do - atBase <- liftIO $ IO.doesFileExist (dir "cabal.project") - if atBase - then return dir - else do - let up = dir ".." - upExist <- liftIO $ IO.doesDirectoryExist up - if upExist - then findUp up - else liftIO $ fail "Could not detect project base directory (containing cabal.project)" - maybeNodeSrc <- liftIO $ IO.lookupEnv "CARDANO_NODE_SRC" - case maybeNodeSrc of - Just path -> return path - Nothing -> findUp "." + let + findUp dir = do + atBase <- liftIO $ IO.doesFileExist (dir "cabal.project") + if atBase + then return dir + else do + let up = dir ".." + upExist <- liftIO $ IO.doesDirectoryExist up + if upExist + then findUp up + else liftIO $ fail "Could not detect project base directory (containing cabal.project)" + maybeNodeSrc <- liftIO $ IO.lookupEnv "CARDANO_NODE_SRC" + case maybeNodeSrc of + Just path -> return path + Nothing -> findUp "." diff --git a/src/Hedgehog/Extras/Test/ProcessIO.hs b/src/Hedgehog/Extras/Test/ProcessIO.hs new file mode 100644 index 00000000..61808c4f --- /dev/null +++ b/src/Hedgehog/Extras/Test/ProcessIO.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Hedgehog.Extras.Test.ProcessIO + ( execFlex + , procFlex + ) where + +import Control.Exception.Annotated (exceptionWithCallStack) +import Control.Monad (Monad (..)) +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bool (Bool (True)) +import Data.Function (($)) +import Data.Int (Int) +import Data.Maybe (Maybe (..)) +import Data.Monoid (Last (..)) +import Data.String (String) +import GHC.Stack (HasCallStack) +import Prelude ((++)) +import System.Exit (ExitCode) +import System.IO (FilePath, IO) +import System.Process (CreateProcess (..)) +import Text.Show (Show (show)) +import UnliftIO.Exception (throwString) + +import qualified Data.List as L +import qualified GHC.Stack as GHC +import Hedgehog.Extras.Internal.Process (binDist) +import Hedgehog.Extras.Test.Process (ExecConfig (..), defaultExecConfig) +import qualified System.Environment as IO +import qualified System.Exit as IO +import qualified System.Process as IO + +-- | Create a process returning its stdout. +-- +-- Being a 'flex' function means that the environment determines how the process is launched. +-- +-- When running in a nix environment, the 'envBin' argument describes the environment variable +-- that defines the binary to use to launch the process. +-- +-- When running outside a nix environment, the `pkgBin` describes the name of the binary +-- to launch via cabal exec. +execFlex + :: HasCallStack + => MonadIO m + => String + -> String + -> [String] + -> m String +execFlex = execFlex' defaultExecConfig + +execFlex' + :: MonadIO m + => HasCallStack + => ExecConfig + -> String + -> String + -> [String] + -> m String +execFlex' execConfig pkgBin envBin arguments = GHC.withFrozenCallStack $ do + (exitResult, stdout', _stderr) <- execFlexAny' execConfig pkgBin envBin arguments + case exitResult of + IO.ExitFailure exitCode -> throwString $ + L.unlines $ + [ "Process exited with non-zero exit-code: " ++ show @Int exitCode ] + ++ (if L.null stdout' then [] else ["━━━━ stdout ━━━━" , stdout']) + ++ (if L.null _stderr then [] else ["━━━━ stderr ━━━━" , _stderr]) + IO.ExitSuccess -> return stdout' + +-- | Run a process, returning its exit code, its stdout, and its stderr. + +-- Contrary to @execFlex'@, this function doesn't fail if the call fails. +-- So, if you want to test something negative, this is the function to use. +execFlexAny' + :: HasCallStack + => MonadIO m + => ExecConfig + -> String -- ^ @pkgBin@: name of the binary to launch via 'cabal exec' + -> String -- ^ @envBin@: environment variable defining the binary to launch the process, when in Nix + -> [String] + -> m (ExitCode, String, String) -- ^ exit code, stdout, stderr +execFlexAny' execConfig pkgBin envBin arguments = GHC.withFrozenCallStack $ do + cp <- procFlex' execConfig pkgBin envBin arguments + --H.annotate . ("━━━━ command ━━━━\n" <>) $ case IO.cmdspec cp of + -- IO.ShellCommand cmd -> cmd + -- IO.RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args) + liftIOAnnotated $ IO.readCreateProcessWithExitCode cp "" + + + +procFlex' + :: HasCallStack + => MonadIO m + => ExecConfig + -> String + -- ^ Cabal package name corresponding to the executable + -> String + -- ^ Environment variable pointing to the binary to run + -> [String] + -- ^ Arguments to the CLI command + -> m CreateProcess + -- ^ Captured stdout +procFlex' execConfig pkg binaryEnv arguments = GHC.withFrozenCallStack $ do + bin <- binFlex pkg binaryEnv + return (IO.proc bin arguments) + { IO.env = getLast $ execConfigEnv execConfig + , IO.cwd = getLast $ 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. +binFlex + :: HasCallStack + => MonadIO m + => String + -- ^ Package name + -> String + -- ^ Environment variable pointing to the binary to run + -> m FilePath + -- ^ Path to executable +binFlex pkg binaryEnv = do + maybeEnvBin <- liftIOAnnotated $ IO.lookupEnv binaryEnv + case maybeEnvBin of + Just envBin -> return envBin + Nothing -> binDist pkg binaryEnv + + +-- | Create a 'CreateProcess' describing how to start a process given the Cabal package name +-- corresponding to the executable, an environment variable pointing to the executable, +-- and an argument list. +-- +-- The actual executable used will the one specified by the environment variable, but if +-- the environment variable is not defined, it will be found instead by consulting the +-- "plan.json" generated by cabal. It is assumed that the project has already been +-- configured and the executable has been built. +procFlex + :: HasCallStack + => 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 + -> m CreateProcess + -- ^ Captured stdout +procFlex = procFlex' defaultExecConfig + + +-- This will also catch async exceptions as well. +liftIOAnnotated :: (HasCallStack, MonadIO m) => IO a -> m a +liftIOAnnotated action = GHC.withFrozenCallStack $ + liftIO $ action `catch` (\(e :: SomeException) -> throwM $ exceptionWithCallStack e) \ No newline at end of file