{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Hedgehog.Extras.Test.Process
( createProcess
, execFlex
, procFlex
, getProjectBase
, waitForProcess
, maybeWaitForProcess
, getPid
, waitSecondsForProcess
) where
import Control.Monad
import Control.Monad.Catch hiding (catch)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register)
import Data.Aeson (eitherDecode)
import Data.Bool
import Data.Either
import Data.Eq
import Data.Function
import Data.Int
import Data.Maybe (Maybe (..))
import Data.Semigroup ((<>))
import Data.String (String)
import GHC.Stack (HasCallStack)
import Hedgehog (MonadTest)
import Hedgehog.Extras.Internal.Cli (argQuote)
import Hedgehog.Extras.Internal.Plan
import Hedgehog.Extras.Stock.IO.Process (TimedOut (..))
import Prelude (error)
import System.Exit (ExitCode)
import System.FilePath.Posix ((</>))
import System.IO (Handle)
import System.Process (CmdSpec (..), CreateProcess (..), Pid, ProcessHandle)
import Text.Show
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List as L
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
planJsonFile :: String
planJsonFile :: String
planJsonFile = IO String -> String
forall a. IO a -> a
IO.unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
Maybe String
maybeBuildDir <- IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
IO.lookupEnv String
"CABAL_BUILDDIR"
case Maybe String
maybeBuildDir of
Just String
buildDir -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
".." String -> String -> String
</> String
buildDir String -> String -> String
</> String
"cache/plan.json"
Maybe String
Nothing -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"../dist-newstyle/cache/plan.json"
{-# NOINLINE planJsonFile #-}
exeSuffix :: String
exeSuffix :: String
exeSuffix = if Bool
OS.isWin32 then String
".exe" else String
""
createProcess
:: (MonadTest m, MonadResource m, HasCallStack)
=> CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle, ReleaseKey)
createProcess :: CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey)
createProcess CreateProcess
cp = (HasCallStack =>
m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey))
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack =>
m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey))
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey))
-> (HasCallStack =>
m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey))
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey)
forall a b. (a -> b) -> a -> b
$ do
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"CWD: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe String -> String
forall a. Show a => a -> String
show (CreateProcess -> Maybe String
IO.cwd CreateProcess
cp)
case CreateProcess -> CmdSpec
IO.cmdspec CreateProcess
cp of
RawCommand String
cmd [String]
args -> String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Command line: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
L.unwords [String]
args
ShellCommand String
cmd -> String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Command line: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd
(Maybe Handle
mhStdin, Maybe Handle
mhStdout, Maybe Handle
mhStderr, ProcessHandle
hProcess) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
IO.createProcess CreateProcess
cp
ReleaseKey
releaseKey <- IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> m ReleaseKey) -> IO () -> m ReleaseKey
forall a b. (a -> b) -> a -> b
$ (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
IO.cleanupProcess (Maybe Handle
mhStdin, Maybe Handle
mhStdout, Maybe Handle
mhStderr, ProcessHandle
hProcess)
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
ReleaseKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
mhStdin, Maybe Handle
mhStdout, Maybe Handle
mhStderr, ProcessHandle
hProcess, ReleaseKey
releaseKey)
getPid
:: (MonadTest m, MonadIO m, HasCallStack)
=> ProcessHandle
-> m (Maybe Pid)
getPid :: ProcessHandle -> m (Maybe Pid)
getPid ProcessHandle
hProcess = m (Maybe Pid) -> m (Maybe Pid)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack (m (Maybe Pid) -> m (Maybe Pid))
-> (IO (Maybe Pid) -> m (Maybe Pid))
-> IO (Maybe Pid)
-> m (Maybe Pid)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe Pid) -> m (Maybe Pid)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Maybe Pid) -> m (Maybe Pid))
-> IO (Maybe Pid) -> m (Maybe Pid)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe Pid)
IO.getPid ProcessHandle
hProcess
execFlex
:: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
=> String
-> String
-> [String]
-> m String
execFlex :: String -> String -> [String] -> m String
execFlex String
pkgBin String
envBin [String]
arguments = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
CreateProcess
cp <- String -> String -> [String] -> m CreateProcess
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
String -> String -> [String] -> m CreateProcess
procFlex String
pkgBin String
envBin [String]
arguments
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> (String -> String) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Command: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ case CreateProcess -> CmdSpec
IO.cmdspec CreateProcess
cp of
IO.ShellCommand String
cmd -> String
cmd
IO.RawCommand String
cmd [String]
args -> String
cmd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
L.unwords [String]
args
(ExitCode
exitResult, String
stdout, String
stderr) <- IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (ExitCode, String, String) -> m (ExitCode, String, String))
-> IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
IO.readCreateProcessWithExitCode CreateProcess
cp String
""
case ExitCode
exitResult of
IO.ExitFailure Int
exitCode -> CallStack -> String -> m String
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
H.failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> m String)
-> ([String] -> String) -> [String] -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
L.unlines ([String] -> m String) -> [String] -> m String
forall a b. (a -> b) -> a -> b
$
[ String
"Process exited with non-zero exit-code"
, String
"━━━━ command ━━━━"
, String
pkgBin String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
L.unwords ((String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
argQuote [String]
arguments)
, String
"━━━━ stdout ━━━━"
, String
stdout
, String
"━━━━ stderr ━━━━"
, String
stderr
, String
"━━━━ exit code ━━━━"
, Int -> String
forall a. Show a => a -> String
show @Int Int
exitCode
]
ExitCode
IO.ExitSuccess -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
stdout
waitForProcess
:: (MonadTest m, MonadIO m, HasCallStack)
=> ProcessHandle
-> m ExitCode
waitForProcess :: ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
hProcess = (HasCallStack => m ExitCode) -> m ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ExitCode) -> m ExitCode)
-> (HasCallStack => m ExitCode) -> m ExitCode
forall a b. (a -> b) -> a -> b
$
IO ExitCode -> m ExitCode
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO ExitCode -> m ExitCode) -> IO ExitCode -> m ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
IO.waitForProcess ProcessHandle
hProcess
maybeWaitForProcess
:: (MonadTest m, MonadIO m, HasCallStack)
=> ProcessHandle
-> m (Maybe ExitCode)
maybeWaitForProcess :: ProcessHandle -> m (Maybe ExitCode)
maybeWaitForProcess ProcessHandle
hProcess = (HasCallStack => m (Maybe ExitCode)) -> m (Maybe ExitCode)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (Maybe ExitCode)) -> m (Maybe ExitCode))
-> (HasCallStack => m (Maybe ExitCode)) -> m (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$
IO (Maybe ExitCode) -> m (Maybe ExitCode)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Maybe ExitCode) -> m (Maybe ExitCode))
-> IO (Maybe ExitCode) -> m (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe ExitCode)
IO.maybeWaitForProcess ProcessHandle
hProcess
waitSecondsForProcess
:: (MonadTest m, MonadIO m, HasCallStack)
=> Int
-> ProcessHandle
-> m (Either TimedOut ExitCode)
waitSecondsForProcess :: Int -> ProcessHandle -> m (Either TimedOut ExitCode)
waitSecondsForProcess Int
seconds ProcessHandle
hProcess = (HasCallStack => m (Either TimedOut ExitCode))
-> m (Either TimedOut ExitCode)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (Either TimedOut ExitCode))
-> m (Either TimedOut ExitCode))
-> (HasCallStack => m (Either TimedOut ExitCode))
-> m (Either TimedOut ExitCode)
forall a b. (a -> b) -> a -> b
$ do
Either TimedOut (Maybe ExitCode)
result <- IO (Either TimedOut (Maybe ExitCode))
-> m (Either TimedOut (Maybe ExitCode))
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Either TimedOut (Maybe ExitCode))
-> m (Either TimedOut (Maybe ExitCode)))
-> IO (Either TimedOut (Maybe ExitCode))
-> m (Either TimedOut (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ Int -> ProcessHandle -> IO (Either TimedOut (Maybe ExitCode))
IO.waitSecondsForProcess Int
seconds ProcessHandle
hProcess
case Either TimedOut (Maybe ExitCode)
result of
Left TimedOut
TimedOut -> do
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate String
"Timed out waiting for process to exit"
Either TimedOut ExitCode -> m (Either TimedOut ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedOut -> Either TimedOut ExitCode
forall a b. a -> Either a b
Left TimedOut
TimedOut)
Right Maybe ExitCode
maybeExitCode -> do
case Maybe ExitCode
maybeExitCode of
Maybe ExitCode
Nothing -> CallStack -> String -> m (Either TimedOut ExitCode)
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
H.failMessage CallStack
HasCallStack => CallStack
GHC.callStack String
"No exit code for process"
Just ExitCode
exitCode -> do
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Process exited " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitCode
Either TimedOut ExitCode -> m (Either TimedOut ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Either TimedOut ExitCode
forall a b. b -> Either a b
Right ExitCode
exitCode)
procDist
:: (MonadTest m, MonadIO m)
=> String
-> [String]
-> m CreateProcess
procDist :: String -> [String] -> m CreateProcess
procDist String
pkg [String]
arguments = do
ByteString
contents <- IO ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO ByteString -> m ByteString)
-> (String -> IO ByteString) -> String -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
LBS.readFile (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
planJsonFile
case ByteString -> Either String Plan
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
contents of
Right Plan
plan -> case (Component -> Bool) -> [Component] -> [Component]
forall a. (a -> Bool) -> [a] -> [a]
L.filter Component -> Bool
matching (Plan
plan Plan -> (Plan -> [Component]) -> [Component]
forall a b. a -> (a -> b) -> b
& Plan -> [Component]
installPlan) of
(Component
component:[Component]
_) -> case Component
component Component -> (Component -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& Component -> Maybe Text
binFile of
Just Text
bin -> CreateProcess -> m CreateProcess
forall (m :: * -> *) a. Monad m => a -> m a
return (CreateProcess -> m CreateProcess)
-> CreateProcess -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ String -> [String] -> CreateProcess
IO.proc (Text -> String
T.unpack Text
bin String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
exeSuffix) [String]
arguments
Maybe Text
Nothing -> String -> m CreateProcess
forall a. HasCallStack => String -> a
error (String -> m CreateProcess) -> String -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ String
"missing bin-file in: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Component -> String
forall a. Show a => a -> String
show Component
component
[] -> String -> m CreateProcess
forall a. HasCallStack => String -> a
error (String -> m CreateProcess) -> String -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ String
"Cannot find exe:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" in plan"
Left String
message -> String -> m CreateProcess
forall a. HasCallStack => String -> a
error (String -> m CreateProcess) -> String -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ String
"Cannot decode plan: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
message
where matching :: Component -> Bool
matching :: Component -> Bool
matching Component
component = case Component -> Maybe Text
componentName Component
component of
Just Text
name -> Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"exe:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pkg
Maybe Text
Nothing -> Bool
False
procFlex
:: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
=> String
-> String
-> [String]
-> m CreateProcess
procFlex :: String -> String -> [String] -> m CreateProcess
procFlex String
pkg String
binaryEnv [String]
arguments = m CreateProcess -> m CreateProcess
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack (m CreateProcess -> m CreateProcess)
-> (m CreateProcess -> m CreateProcess)
-> m CreateProcess
-> m CreateProcess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m CreateProcess -> m CreateProcess
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM (m CreateProcess -> m CreateProcess)
-> m CreateProcess -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ do
Maybe String
maybeEnvBin <- IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
IO.lookupEnv String
binaryEnv
case Maybe String
maybeEnvBin of
Just String
envBin -> CreateProcess -> m CreateProcess
forall (m :: * -> *) a. Monad m => a -> m a
return (CreateProcess -> m CreateProcess)
-> CreateProcess -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ String -> [String] -> CreateProcess
IO.proc String
envBin [String]
arguments
Maybe String
Nothing -> String -> [String] -> m CreateProcess
forall (m :: * -> *).
(MonadTest m, MonadIO m) =>
String -> [String] -> m CreateProcess
procDist String
pkg [String]
arguments
getProjectBase
:: (MonadTest m, MonadIO m)
=> m String
getProjectBase :: m String
getProjectBase = do
Maybe String
maybeNodeSrc <- IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
IO.lookupEnv String
"CARDANO_NODE_SRC"
case Maybe String
maybeNodeSrc of
Just String
path -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
Maybe String
Nothing -> do
Bool
atBase <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesFileExist String
"cabal.project"
if Bool
atBase
then String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"."
else String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
".."