{-# 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

  , 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
  { ExecConfig -> Last [([Char], [Char])]
execConfigEnv :: Last [(String, String)]
  , ExecConfig -> Last [Char]
execConfigCwd :: Last FilePath
  } deriving (ExecConfig -> ExecConfig -> Bool
(ExecConfig -> ExecConfig -> Bool)
-> (ExecConfig -> ExecConfig -> Bool) -> Eq ExecConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExecConfig -> ExecConfig -> Bool
== :: ExecConfig -> ExecConfig -> Bool
$c/= :: ExecConfig -> ExecConfig -> Bool
/= :: ExecConfig -> ExecConfig -> Bool
Eq, (forall x. ExecConfig -> Rep ExecConfig x)
-> (forall x. Rep ExecConfig x -> ExecConfig) -> Generic ExecConfig
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
$cfrom :: forall x. ExecConfig -> Rep ExecConfig x
from :: forall x. ExecConfig -> Rep ExecConfig x
$cto :: forall x. Rep ExecConfig x -> ExecConfig
to :: forall x. Rep ExecConfig x -> ExecConfig
Generic, Int -> ExecConfig -> ShowS
[ExecConfig] -> ShowS
ExecConfig -> [Char]
(Int -> ExecConfig -> ShowS)
-> (ExecConfig -> [Char])
-> ([ExecConfig] -> ShowS)
-> Show ExecConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecConfig -> ShowS
showsPrec :: Int -> ExecConfig -> ShowS
$cshow :: ExecConfig -> [Char]
show :: ExecConfig -> [Char]
$cshowList :: [ExecConfig] -> ShowS
showList :: [ExecConfig] -> ShowS
Show)

defaultExecConfig :: ExecConfig
defaultExecConfig :: ExecConfig
defaultExecConfig = ExecConfig
  { execConfigEnv :: Last [([Char], [Char])]
execConfigEnv = Last [([Char], [Char])]
forall a. Monoid a => a
mempty
  , execConfigCwd :: Last [Char]
execConfigCwd = Last [Char]
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 IO [Char] -> ([Char] -> IO [Char]) -> IO [Char]
forall a b. IO a -> (a -> IO b) -> IO b
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 planRelPath :: [Char]
planRelPath = [Char]
"dist-newstyle/cache/plan.json"
              file :: [Char]
file = [Char]
d [Char] -> ShowS
</> [Char]
planRelPath
          Bool
exists <- [Char] -> IO Bool
IO.doesFileExist [Char]
file
          if Bool
exists
            then [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
file
            else do
              let parent :: [Char]
parent = ShowS
takeDirectory [Char]
d
              if [Char]
parent [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
d
                then [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
planRelPath
                else [Char] -> IO [Char]
go [Char]
parent

-- | Discover the location of the plan.json file.
planJsonFile :: String
planJsonFile :: [Char]
planJsonFile = IO [Char] -> [Char]
forall a. IO a -> a
IO.unsafePerformIO (IO [Char] -> [Char]) -> IO [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ do
  Maybe [Char]
maybeBuildDir <- IO (Maybe [Char]) -> IO (Maybe [Char])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> IO (Maybe [Char]))
-> IO (Maybe [Char]) -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
"CABAL_BUILDDIR"
  case Maybe [Char]
maybeBuildDir of
    Just [Char]
buildDir -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
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" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` [Char]
s
  then [Char]
s
  else [Char]
s [Char] -> ShowS
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 = (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
  [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"CWD: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe [Char] -> [Char]
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 -> [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Command line: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
cmd [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords [[Char]]
args
    ShellCommand [Char]
cmd -> [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Command line: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
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 a. a -> m a
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 = m (Maybe Pid) -> m (Maybe Pid)
(HasCallStack => 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

-- | 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 = (HasCallStack => m Pid) -> m Pid
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m Pid) -> m Pid)
-> (HasCallStack => m Pid) -> m Pid
forall a b. (a -> b) -> a -> b
$
  m (Maybe Pid) -> m Pid
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
m (Maybe a) -> m a
H.nothingFailM (m (Maybe Pid) -> m Pid) -> m (Maybe Pid) -> m Pid
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> m (Maybe Pid)
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 = ExecConfig -> [Char] -> [Char] -> [[Char]] -> m [Char]
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 = (HasCallStack => m [Char]) -> m [Char]
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m [Char]) -> m [Char])
-> (HasCallStack => m [Char]) -> m [Char]
forall a b. (a -> b) -> a -> b
$ do
  (ExitCode
exitResult, [Char]
stdout, [Char]
stderr) <- ExecConfig
-> [Char] -> [Char] -> [[Char]] -> m (ExitCode, [Char], [Char])
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig
-> [Char] -> [Char] -> [[Char]] -> m (ExitCode, [Char], [Char])
execFlexAny' ExecConfig
execConfig [Char]
pkgBin [Char]
envBin [[Char]]
arguments
  case ExitCode
exitResult of
    IO.ExitFailure Int
exitCode -> do
      [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
L.unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        [ [Char]
"Process exited with non-zero exit-code: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show @Int Int
exitCode ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Char]
stdout then [] else [[Char]
"━━━━ stdout ━━━━" , [Char]
stdout])
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Char]
stderr then [] else [[Char]
"━━━━ stderr ━━━━" , [Char]
stderr])
      CallStack -> [Char] -> m [Char]
forall (m :: * -> *) a. MonadTest m => CallStack -> [Char] -> m a
H.failMessage CallStack
HasCallStack => CallStack
GHC.callStack [Char]
"Execute process failed"
    ExitCode
IO.ExitSuccess -> [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
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
execFlexAny' :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig
-> [Char] -> [Char] -> [[Char]] -> m (ExitCode, [Char], [Char])
execFlexAny' ExecConfig
execConfig [Char]
pkgBin [Char]
envBin [[Char]]
arguments = (HasCallStack => m (ExitCode, [Char], [Char]))
-> m (ExitCode, [Char], [Char])
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (ExitCode, [Char], [Char]))
 -> m (ExitCode, [Char], [Char]))
-> (HasCallStack => m (ExitCode, [Char], [Char]))
-> m (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ do
  CreateProcess
cp <- ExecConfig -> [Char] -> [Char] -> [[Char]] -> m CreateProcess
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [Char] -> [[Char]] -> m CreateProcess
procFlex' ExecConfig
execConfig [Char]
pkgBin [Char]
envBin [[Char]]
arguments
  [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate ([Char] -> m ()) -> ShowS -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"━━━━ command ━━━━\n" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> m ()) -> [Char] -> m ()
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 [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords (ShowS
argQuote ShowS -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
args)
  IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char])
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ CreateProcess -> [Char] -> IO (ExitCode, [Char], [Char])
IO.readCreateProcessWithExitCode CreateProcess
cp [Char]
""

-- | 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 = m [Char] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [Char] -> m ()) -> m [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ ExecConfig -> [Char] -> [[Char]] -> m [Char]
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [[Char]] -> m [Char]
exec ExecConfig
execConfig [Char]
bin [[Char]]
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
exec :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [[Char]] -> m [Char]
exec ExecConfig
execConfig [Char]
bin [[Char]]
arguments = (HasCallStack => m [Char]) -> m [Char]
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m [Char]) -> m [Char])
-> (HasCallStack => m [Char]) -> m [Char]
forall a b. (a -> b) -> a -> b
$ do
  (ExitCode
exitResult, [Char]
stdout, [Char]
stderr) <- ExecConfig -> [Char] -> [[Char]] -> m (ExitCode, [Char], [Char])
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [[Char]] -> m (ExitCode, [Char], [Char])
execAny ExecConfig
execConfig [Char]
bin [[Char]]
arguments
  case ExitCode
exitResult of
    IO.ExitFailure Int
exitCode -> CallStack -> [Char] -> m [Char]
forall (m :: * -> *) a. MonadTest m => CallStack -> [Char] -> m a
H.failMessage CallStack
HasCallStack => CallStack
GHC.callStack ([Char] -> m [Char])
-> ([[Char]] -> [Char]) -> [[Char]] -> m [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
L.unlines ([[Char]] -> m [Char]) -> [[Char]] -> m [Char]
forall a b. (a -> b) -> a -> b
$
      [ [Char]
"Process exited with non-zero exit-code: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show @Int Int
exitCode ]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Char]
stdout then [] else [[Char]
"━━━━ stdout ━━━━" , [Char]
stdout])
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Char]
stderr then [] else [[Char]
"━━━━ stderr ━━━━" , [Char]
stderr])
    ExitCode
IO.ExitSuccess -> [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
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 :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
ExecConfig -> [Char] -> [[Char]] -> m (ExitCode, [Char], [Char])
execAny ExecConfig
execConfig [Char]
bin [[Char]]
arguments = (HasCallStack => m (ExitCode, [Char], [Char]))
-> m (ExitCode, [Char], [Char])
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (ExitCode, [Char], [Char]))
 -> m (ExitCode, [Char], [Char]))
-> (HasCallStack => m (ExitCode, [Char], [Char]))
-> m (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ do
  let cp :: CreateProcess
cp = ([Char] -> [[Char]] -> CreateProcess
IO.proc [Char]
bin [[Char]]
arguments)
        { IO.env = getLast $ execConfigEnv execConfig
        , IO.cwd = getLast $ execConfigCwd execConfig
        }
  [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate ([Char] -> m ()) -> ShowS -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( [Char]
"━━━━ command ━━━━\n" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
bin [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
L.unwords (ShowS
argQuote ShowS -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
arguments)
  IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char])
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ CreateProcess -> [Char] -> IO (ExitCode, [Char], [Char])
IO.readCreateProcessWithExitCode CreateProcess
cp [Char]
""

-- | 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 = (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

-- | 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 = (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

-- | 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 = (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
      [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate [Char]
"Timed out waiting for process to exit"
      Either TimedOut ExitCode -> m (Either TimedOut ExitCode)
forall a. a -> m a
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 -> [Char] -> m (Either TimedOut ExitCode)
forall (m :: * -> *) a. MonadTest m => CallStack -> [Char] -> m a
H.failMessage CallStack
HasCallStack => CallStack
GHC.callStack [Char]
"No exit code for process"
        Just ExitCode
exitCode -> do
          [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
H.annotate ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Process exited " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ExitCode -> [Char]
forall a. Show a => a -> [Char]
show ExitCode
exitCode
          Either TimedOut ExitCode -> m (Either TimedOut ExitCode)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Either TimedOut ExitCode
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
  :: (HasCallStack, MonadTest m, MonadIO m)
  => String
  -- ^ Package name
  -> String
  -- ^ Environment variable pointing to the binary to run
  -> m FilePath
  -- ^ Path to executable
binFlex :: forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binFlex [Char]
pkg [Char]
binaryEnv = do
  Maybe [Char]
maybeEnvBin <- IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> m (Maybe [Char]))
-> IO (Maybe [Char]) -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
binaryEnv
  case Maybe [Char]
maybeEnvBin of
    Just [Char]
envBin -> [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
envBin
    Maybe [Char]
Nothing -> [Char] -> [Char] -> m [Char]
forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binDist [Char]
pkg [Char]
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 :: forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binDist [Char]
pkg [Char]
binaryEnv = do
  Bool
doesPlanExist <- IO Bool -> m Bool
forall a. IO a -> m a
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
$ [Char] -> IO Bool
IO.doesFileExist [Char]
planJsonFile
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
doesPlanExist (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find plan.json in the path: "
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
planJsonFile
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
". Please run \"cabal build "
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
pkg
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\" if you are working with sources. Otherwise define "
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
binaryEnv
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" and have it point to the executable you want."

  Plan{[Component]
installPlan :: [Component]
installPlan :: Plan -> [Component]
installPlan} <- ByteString -> Either [Char] Plan
forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode (ByteString -> Either [Char] Plan)
-> m ByteString -> m (Either [Char] Plan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO ([Char] -> IO ByteString
LBS.readFile [Char]
planJsonFile)
      m (Either [Char] Plan) -> (Either [Char] Plan -> m Plan) -> m Plan
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left [Char]
message -> [Char] -> m Plan
forall a. HasCallStack => [Char] -> a
error ([Char] -> m Plan) -> [Char] -> m Plan
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot decode plan in " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
planJsonFile [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
message
        Right Plan
plan -> Plan -> m Plan
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Plan
plan

  let componentName :: Text
componentName = Text
"exe:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. IsString a => [Char] -> a
fromString [Char]
pkg
  case Text -> [Component] -> Maybe Component
findComponent Text
componentName [Component]
installPlan of
    Just Component{binFile :: Component -> Maybe Text
binFile=Just Text
binFilePath} -> [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> m [Char]) -> ShowS -> [Char] -> m [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
addExeSuffix ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
binFilePath
    Just component :: Component
component@Component{binFile :: Component -> Maybe Text
binFile=Maybe Text
Nothing} ->
      [Char] -> m [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"missing \"bin-file\" key in plan component: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Component -> [Char]
forall a. Show a => a -> [Char]
show Component
component [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" in the plan in: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
planJsonFile
    Maybe Component
Nothing ->
      [Char] -> m [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot find \"component-name\" key with the value \"exe:" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
pkg [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\" in the plan in: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
planJsonFile
  where
    findComponent :: Text -> [Component] -> Maybe Component
    findComponent :: Text -> [Component] -> Maybe Component
findComponent Text
_ [] = Maybe Component
forall a. Maybe a
Nothing
    findComponent Text
needle (c :: Component
c@Component{Maybe Text
componentName :: Maybe Text
componentName :: Component -> Maybe Text
componentName, [Component]
components :: [Component]
components :: Component -> [Component]
components}:[Component]
topLevelComponents)
      | Maybe Text
componentName Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
needle = Component -> Maybe Component
forall a. a -> Maybe a
Just Component
c
      | Bool
otherwise = Text -> [Component] -> Maybe Component
findComponent Text
needle [Component]
topLevelComponents Maybe Component -> Maybe Component -> Maybe Component
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> [Component] -> Maybe Component
findComponent Text
needle [Component]
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
procFlex :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
[Char] -> [Char] -> [[Char]] -> m CreateProcess
procFlex = ExecConfig -> [Char] -> [Char] -> [[Char]] -> m CreateProcess
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 = m CreateProcess -> m CreateProcess
(HasCallStack => 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
  [Char]
bin <- [Char] -> [Char] -> m [Char]
forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
[Char] -> [Char] -> m [Char]
binFlex [Char]
pkg [Char]
binaryEnv
  CreateProcess -> m CreateProcess
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [[Char]] -> CreateProcess
IO.proc [Char]
bin [[Char]]
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 :: forall (m :: * -> *). (MonadTest m, MonadIO m) => m [Char]
getProjectBase = do
  let
    findUp :: [Char] -> m [Char]
findUp [Char]
dir = do
      Bool
atBase <- IO Bool -> m Bool
forall a. IO a -> m a
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
$ [Char] -> IO Bool
IO.doesFileExist ([Char]
dir [Char] -> ShowS
</> [Char]
"cabal.project")
      if Bool
atBase
        then [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
dir
        else do
          let up :: [Char]
up = [Char]
dir [Char] -> ShowS
</> [Char]
".."
          Bool
upExist <- IO Bool -> m Bool
forall a. IO a -> m a
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
$ [Char] -> IO Bool
IO.doesDirectoryExist [Char]
up
          if Bool
upExist
            then [Char] -> m [Char]
findUp [Char]
up
            else IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Could not detect project base directory (containing cabal.project)"
  Maybe [Char]
maybeNodeSrc <- IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> m (Maybe [Char]))
-> IO (Maybe [Char]) -> m (Maybe [Char])
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 -> [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
path
    Maybe [Char]
Nothing -> [Char] -> m [Char]
forall {m :: * -> *}. MonadIO m => [Char] -> m [Char]
findUp [Char]
"."