{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Hedgehog.Extras.Test.Process
  ( createProcess
  , exec
  , exec_
  , execFlex
  , execFlex'
  , 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.Aeson (eitherDecode)
import           Data.Bool (Bool (..))
import           Data.Either (Either (..))
import           Data.Eq (Eq (..))
import           Data.Function (($), (&), (.))
import           Data.Functor (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           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 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
  { ExecConfig -> Last [([Char], [Char])]
execConfigEnv :: Last [(String, String)]
  , ExecConfig -> Last [Char]
execConfigCwd :: Last FilePath
  } deriving (ExecConfig -> ExecConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExecConfig -> ExecConfig -> Bool
$c/= :: ExecConfig -> ExecConfig -> Bool
== :: ExecConfig -> ExecConfig -> Bool
$c== :: ExecConfig -> ExecConfig -> Bool
Eq, forall x. Rep ExecConfig x -> ExecConfig
forall x. ExecConfig -> Rep ExecConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ExecConfig x -> ExecConfig
$cfrom :: forall x. ExecConfig -> Rep ExecConfig x
Generic, Int -> ExecConfig -> ShowS
[ExecConfig] -> ShowS
ExecConfig -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ExecConfig] -> ShowS
$cshowList :: [ExecConfig] -> ShowS
show :: ExecConfig -> [Char]
$cshow :: ExecConfig -> [Char]
showsPrec :: Int -> ExecConfig -> ShowS
$cshowsPrec :: Int -> ExecConfig -> ShowS
Show)

defaultExecConfig :: ExecConfig
defaultExecConfig :: ExecConfig
defaultExecConfig = ExecConfig
  { execConfigEnv :: Last [([Char], [Char])]
execConfigEnv = forall a. Monoid a => a
mempty
  , execConfigCwd :: Last [Char]
execConfigCwd = forall a. Monoid a => a
mempty
  }

-- | Find the nearest plan.json going upwards from the current directory.
findDefaultPlanJsonFile :: IO FilePath
findDefaultPlanJsonFile :: IO [Char]
findDefaultPlanJsonFile = IO [Char]
IO.getCurrentDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO [Char]
go
  where go :: FilePath -> IO FilePath
        go :: [Char] -> IO [Char]
go [Char]
d = do
          let file :: [Char]
file = [Char]
d [Char] -> ShowS
</> [Char]
"dist-newstyle/cache/plan.json"
          Bool
exists <- [Char] -> IO Bool
IO.doesFileExist [Char]
file
          if Bool
exists
            then forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
file
            else do
              let parent :: [Char]
parent = ShowS
takeDirectory [Char]
d
              if [Char]
parent forall a. Eq a => a -> a -> Bool
== [Char]
d
                then forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"dist-newstyle/cache/plan.json"
                else [Char] -> IO [Char]
go [Char]
parent

-- | Discover the location of the plan.json file.
planJsonFile :: String
planJsonFile :: [Char]
planJsonFile = forall a. IO a -> a
IO.unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  Maybe [Char]
maybeBuildDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
"CABAL_BUILDDIR"
  case Maybe [Char]
maybeBuildDir of
    Just [Char]
buildDir -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
</> [Char]
buildDir [Char] -> ShowS
</> [Char]
"cache/plan.json"
    Maybe [Char]
Nothing -> IO [Char]
findDefaultPlanJsonFile
{-# NOINLINE planJsonFile #-}

exeSuffix :: String
exeSuffix :: [Char]
exeSuffix = if Bool
OS.isWin32 then [Char]
".exe" else [Char]
""

addExeSuffix :: String -> String
addExeSuffix :: ShowS
addExeSuffix [Char]
s = if [Char]
".exe" forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` [Char]
s
  then [Char]
s
  else [Char]
s forall a. Semigroup a => a -> a -> a
<> [Char]
exeSuffix

-- | 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 :: forall (m :: * -> *).
(MonadTest m, MonadResource m, HasCallStack) =>
CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
      ReleaseKey)
createProcess CreateProcess
cp = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ [Char]
"CWD: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (CreateProcess -> Maybe [Char]
IO.cwd CreateProcess
cp)
  case CreateProcess -> CmdSpec
IO.cmdspec CreateProcess
cp of
    RawCommand [Char]
cmd [[Char]]
args -> forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ [Char]
"Command line: " forall a. Semigroup a => a -> a -> a
<> [Char]
cmd forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords [[Char]]
args
    ShellCommand [Char]
cmd -> forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ [Char]
"Command line: " forall a. Semigroup a => a -> a -> a
<> [Char]
cmd
  (Maybe Handle
mhStdin, Maybe Handle
mhStdout, Maybe Handle
mhStderr, ProcessHandle
hProcess) <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
IO.createProcess CreateProcess
cp
  ReleaseKey
releaseKey <- forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register 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)

  forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
mhStdin, Maybe Handle
mhStdout, Maybe Handle
mhStderr, ProcessHandle
hProcess, ReleaseKey
releaseKey)

-- | Get the process ID.
getPid
  :: (MonadTest m, MonadIO m, HasCallStack)
  => ProcessHandle
  -> m (Maybe Pid)
getPid :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ProcessHandle -> m (Maybe Pid)
getPid ProcessHandle
hProcess = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe Pid)
IO.getPid ProcessHandle
hProcess

-- | Get the process ID.
getPidOk
  :: (MonadTest m, MonadIO m, HasCallStack)
  => ProcessHandle
  -> m Pid
getPidOk :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ProcessHandle -> m Pid
getPidOk ProcessHandle
hProcess = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
m (Maybe a) -> m a
H.nothingFailM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ProcessHandle -> m (Maybe Pid)
getPid ProcessHandle
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 :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
[Char] -> [Char] -> [[Char]] -> m [Char]
execFlex = forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [Char] -> [[Char]] -> m [Char]
execFlex' ExecConfig
defaultExecConfig

execFlex'
  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
  => ExecConfig
  -> String
  -> String
  -> [String]
  -> m String
execFlex' :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [Char] -> [[Char]] -> m [Char]
execFlex' ExecConfig
execConfig [Char]
pkgBin [Char]
envBin [[Char]]
arguments = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  CreateProcess
cp <- forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [Char] -> [[Char]] -> m CreateProcess
procFlex' ExecConfig
execConfig [Char]
pkgBin [Char]
envBin [[Char]]
arguments
  forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Command: " forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ case CreateProcess -> CmdSpec
IO.cmdspec CreateProcess
cp of
    IO.ShellCommand [Char]
cmd -> [Char]
cmd
    IO.RawCommand [Char]
cmd [[Char]]
args -> [Char]
cmd forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords [[Char]]
args
  (ExitCode
exitResult, [Char]
stdout, [Char]
stderr) <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ CreateProcess -> [Char] -> IO (ExitCode, [Char], [Char])
IO.readCreateProcessWithExitCode CreateProcess
cp [Char]
""
  case ExitCode
exitResult of
    IO.ExitFailure Int
exitCode -> do
      forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
L.unlines forall a b. (a -> b) -> a -> b
$
        [ [Char]
"Process exited with non-zero exit-code"
        , [Char]
"━━━━ command ━━━━"
        , [Char]
pkgBin forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
argQuote [[Char]]
arguments)
        , [Char]
"━━━━ stdout ━━━━"
        , [Char]
stdout
        , [Char]
"━━━━ stderr ━━━━"
        , [Char]
stderr
        , [Char]
"━━━━ exit code ━━━━"
        , forall a. Show a => a -> [Char]
show @Int Int
exitCode
        ]
      forall (m :: * -> *) a. MonadTest m => CallStack -> [Char] -> m a
H.failMessage HasCallStack => CallStack
GHC.callStack [Char]
"Execute process failed"
    ExitCode
IO.ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
stdout

-- | Execute a process, returning '()'.
exec_
  :: (MonadTest m, MonadIO m, HasCallStack)
  => ExecConfig
  -> String
  -> [String]
  -> m ()
exec_ :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [[Char]] -> m ()
exec_ ExecConfig
execConfig [Char]
bin [[Char]]
arguments = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [[Char]] -> m [Char]
exec ExecConfig
execConfig [Char]
bin [[Char]]
arguments

-- | Execute a process
exec
  :: (MonadTest m, MonadIO m, HasCallStack)
  => ExecConfig
  -> String
  -> [String]
  -> m String
exec :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [[Char]] -> m [Char]
exec ExecConfig
execConfig [Char]
bin [[Char]]
arguments = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  let cp :: CreateProcess
cp = ([Char] -> [[Char]] -> CreateProcess
IO.proc [Char]
bin [[Char]]
arguments)
        { env :: Maybe [([Char], [Char])]
IO.env = forall a. Last a -> Maybe a
getLast forall a b. (a -> b) -> a -> b
$ ExecConfig -> Last [([Char], [Char])]
execConfigEnv ExecConfig
execConfig
        , cwd :: Maybe [Char]
IO.cwd = forall a. Last a -> Maybe a
getLast forall a b. (a -> b) -> a -> b
$ ExecConfig -> Last [Char]
execConfigCwd ExecConfig
execConfig
        }
  forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Command: " forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ [Char]
bin forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords [[Char]]
arguments
  (ExitCode
exitResult, [Char]
stdout, [Char]
stderr) <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ CreateProcess -> [Char] -> IO (ExitCode, [Char], [Char])
IO.readCreateProcessWithExitCode CreateProcess
cp [Char]
""
  case ExitCode
exitResult of
    IO.ExitFailure Int
exitCode -> forall (m :: * -> *) a. MonadTest m => CallStack -> [Char] -> m a
H.failMessage HasCallStack => CallStack
GHC.callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
L.unlines forall a b. (a -> b) -> a -> b
$
      [ [Char]
"Process exited with non-zero exit-code"
      , [Char]
"━━━━ command ━━━━"
      , [Char]
bin forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
argQuote [[Char]]
arguments)
      , [Char]
"━━━━ stdout ━━━━"
      , [Char]
stdout
      , [Char]
"━━━━ stderr ━━━━"
      , [Char]
stderr
      , [Char]
"━━━━ exit code ━━━━"
      , forall a. Show a => a -> [Char]
show @Int Int
exitCode
      ]
    ExitCode
IO.ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
stdout

-- | Wait for process to exit.
waitForProcess
  :: (MonadTest m, MonadIO m, HasCallStack)
  => ProcessHandle
  -> m ExitCode
waitForProcess :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
hProcess = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
IO.waitForProcess ProcessHandle
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 :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ProcessHandle -> m (Maybe ExitCode)
maybeWaitForProcess ProcessHandle
hProcess = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe ExitCode)
IO.maybeWaitForProcess ProcessHandle
hProcess

-- | Wait a maximum of 'seconds' secons for process to exit.
waitSecondsForProcess
  :: (MonadTest m, MonadIO m, HasCallStack)
  => Int
  -> ProcessHandle
  -> m (Either TimedOut ExitCode)
waitSecondsForProcess :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
Int -> ProcessHandle -> m (Either TimedOut ExitCode)
waitSecondsForProcess Int
seconds ProcessHandle
hProcess = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  Either TimedOut (Maybe ExitCode)
result <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO 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
      forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate [Char]
"Timed out waiting for process to exit"
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left TimedOut
TimedOut)
    Right Maybe ExitCode
maybeExitCode -> do
      case Maybe ExitCode
maybeExitCode of
        Maybe ExitCode
Nothing -> forall (m :: * -> *) a. MonadTest m => CallStack -> [Char] -> m a
H.failMessage HasCallStack => CallStack
GHC.callStack [Char]
"No exit code for process"
        Just ExitCode
exitCode -> do
          forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ [Char]
"Process exited " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ExitCode
exitCode
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ExitCode
exitCode)

-- | Compute the path to the binary given a package name or an environment variable override.
binFlex
  :: (MonadTest m, MonadIO m)
  => String
  -- ^ Package name
  -> String
  -- ^ Environment variable pointing to the binary to run
  -> m FilePath
  -- ^ Path to executable
binFlex :: forall (m :: * -> *).
(MonadTest m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binFlex [Char]
pkg [Char]
binaryEnv = do
  Maybe [Char]
maybeEnvBin <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
binaryEnv
  case Maybe [Char]
maybeEnvBin of
    Just [Char]
envBin -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
envBin
    Maybe [Char]
Nothing -> forall (m :: * -> *).
(MonadTest m, MonadIO m) =>
[Char] -> m [Char]
binDist [Char]
pkg

-- | 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
  :: (MonadTest m, MonadIO m)
  => String
  -- ^ Package name
  -> m FilePath
  -- ^ Path to executable
binDist :: forall (m :: * -> *).
(MonadTest m, MonadIO m) =>
[Char] -> m [Char]
binDist [Char]
pkg = do
  ByteString
contents <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ByteString
LBS.readFile forall a b. (a -> b) -> a -> b
$ [Char]
planJsonFile

  case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
contents of
    Right Plan
plan -> case forall a. (a -> Bool) -> [a] -> [a]
L.filter Component -> Bool
matching (Plan
plan forall a b. a -> (a -> b) -> b
& Plan -> [Component]
installPlan) of
      (Component
component:[Component]
_) -> case Component
component forall a b. a -> (a -> b) -> b
& Component -> Maybe Text
binFile of
        Just Text
bin -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ShowS
addExeSuffix (Text -> [Char]
T.unpack Text
bin)
        Maybe Text
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"missing bin-file in: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Component
component
      [] -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot find exe:" forall a. Semigroup a => a -> a -> a
<> [Char]
pkg forall a. Semigroup a => a -> a -> a
<> [Char]
" in plan"
    Left [Char]
message -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot decode plan: " forall a. Semigroup a => a -> a -> a
<> [Char]
message
  where matching :: Component -> Bool
        matching :: Component -> Bool
matching Component
component = case Component -> Maybe Text
componentName Component
component of
          Just Text
name -> Text
name forall a. Eq a => a -> a -> Bool
== Text
"exe:" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
pkg
          Maybe Text
Nothing -> Bool
False

-- | 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
procFlex :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
[Char] -> [Char] -> [[Char]] -> m CreateProcess
procFlex = forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [Char] -> [[Char]] -> m CreateProcess
procFlex' ExecConfig
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' :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [Char] -> [[Char]] -> m CreateProcess
procFlex' ExecConfig
execConfig [Char]
pkg [Char]
binaryEnv [[Char]]
arguments = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM forall a b. (a -> b) -> a -> b
$ do
  [Char]
bin <- forall (m :: * -> *).
(MonadTest m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binFlex [Char]
pkg [Char]
binaryEnv
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [[Char]] -> CreateProcess
IO.proc [Char]
bin [[Char]]
arguments)
    { env :: Maybe [([Char], [Char])]
IO.env = forall a. Last a -> Maybe a
getLast forall a b. (a -> b) -> a -> b
$ ExecConfig -> Last [([Char], [Char])]
execConfigEnv ExecConfig
execConfig
    , cwd :: Maybe [Char]
IO.cwd = forall a. Last a -> Maybe a
getLast forall a b. (a -> b) -> a -> b
$ ExecConfig -> Last [Char]
execConfigCwd ExecConfig
execConfig
    }

-- | 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 :: forall (m :: * -> *). (MonadTest m, MonadIO m) => m [Char]
getProjectBase = do
  let
    findUp :: [Char] -> m [Char]
findUp [Char]
dir = do
      Bool
atBase <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
IO.doesFileExist ([Char]
dir [Char] -> ShowS
</> [Char]
"cabal.project")
      if Bool
atBase
        then forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
dir
        else do
          let up :: [Char]
up = [Char]
dir [Char] -> ShowS
</> [Char]
".."
          Bool
upExist <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
IO.doesDirectoryExist [Char]
up
          if Bool
upExist
            then [Char] -> m [Char]
findUp [Char]
up
            else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Could not detect project base directory (containing cabal.project)"
  Maybe [Char]
maybeNodeSrc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
"CARDANO_NODE_SRC"
  case Maybe [Char]
maybeNodeSrc of
    Just [Char]
path -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
path
    Maybe [Char]
Nothing -> forall {m :: * -> *}. MonadIO m => [Char] -> m [Char]
findUp [Char]
"."