{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

module Cradle.ProcessConfiguration
  ( ProcessConfiguration (..),
    StdinConfig (..),
    OutputStreamConfig (..),
    silenceDefault,
    addHandle,
    cmd,
    ProcessResult (..),
    runProcess,
  )
where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString, hGetContents, hGetSome, hPut, null)
import System.Environment (getEnvironment)
import System.Exit
import System.IO (Handle)
import System.Posix.Internals (hostIsThreaded)
import System.Process
  ( CreateProcess (..),
    ProcessHandle,
    StdStream (..),
    cleanupProcess,
    createProcess_,
    proc,
    waitForProcess,
  )

data ProcessConfiguration = ProcessConfiguration
  { ProcessConfiguration -> String
executable :: String,
    ProcessConfiguration -> [String]
arguments :: [String],
    ProcessConfiguration
-> Maybe ([(String, String)] -> [(String, String)])
environmentModification :: Maybe ([(String, String)] -> [(String, String)]),
    ProcessConfiguration -> Maybe String
workingDir :: Maybe FilePath,
    ProcessConfiguration -> Bool
throwOnError :: Bool,
    ProcessConfiguration -> StdinConfig
stdinConfig :: StdinConfig,
    ProcessConfiguration -> OutputStreamConfig
stdoutConfig :: OutputStreamConfig,
    ProcessConfiguration -> OutputStreamConfig
stderrConfig :: OutputStreamConfig,
    ProcessConfiguration -> Bool
delegateCtlc :: Bool
  }

data StdinConfig
  = InheritStdin
  | UseStdinHandle Handle
  | NoStdinStream

data OutputStreamConfig = OutputStreamConfig
  { OutputStreamConfig -> Bool
capture :: Bool,
    -- | Handles that the user set for the output stream.
    --
    -- @Nothing@ means use the default behavior (which depends on the @capture@
    -- field).
    OutputStreamConfig -> Maybe [Handle]
setHandles :: Maybe [Handle]
  }
  deriving stock (Int -> OutputStreamConfig -> ShowS
[OutputStreamConfig] -> ShowS
OutputStreamConfig -> String
(Int -> OutputStreamConfig -> ShowS)
-> (OutputStreamConfig -> String)
-> ([OutputStreamConfig] -> ShowS)
-> Show OutputStreamConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OutputStreamConfig -> ShowS
showsPrec :: Int -> OutputStreamConfig -> ShowS
$cshow :: OutputStreamConfig -> String
show :: OutputStreamConfig -> String
$cshowList :: [OutputStreamConfig] -> ShowS
showList :: [OutputStreamConfig] -> ShowS
Show)

defaultOutputStreamConfig :: OutputStreamConfig
defaultOutputStreamConfig :: OutputStreamConfig
defaultOutputStreamConfig = Bool -> Maybe [Handle] -> OutputStreamConfig
OutputStreamConfig Bool
False Maybe [Handle]
forall a. Maybe a
Nothing

silenceDefault :: OutputStreamConfig -> OutputStreamConfig
silenceDefault :: OutputStreamConfig -> OutputStreamConfig
silenceDefault OutputStreamConfig
config =
  OutputStreamConfig
config
    { setHandles = case setHandles config of
        Maybe [Handle]
Nothing -> [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just []
        Just [Handle]
handles -> [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just [Handle]
handles
    }

addHandle :: Handle -> OutputStreamConfig -> OutputStreamConfig
addHandle :: Handle -> OutputStreamConfig -> OutputStreamConfig
addHandle Handle
handle OutputStreamConfig
config =
  OutputStreamConfig
config
    { setHandles = case setHandles config of
        Maybe [Handle]
Nothing -> [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just [Handle
handle]
        Just [Handle]
hs -> [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just ([Handle] -> Maybe [Handle]) -> [Handle] -> Maybe [Handle]
forall a b. (a -> b) -> a -> b
$ Handle
handle Handle -> [Handle] -> [Handle]
forall a. a -> [a] -> [a]
: [Handle]
hs
    }

cmd :: String -> ProcessConfiguration
cmd :: String -> ProcessConfiguration
cmd String
executable =
  ProcessConfiguration
    { executable :: String
executable = String
executable,
      arguments :: [String]
arguments = [],
      environmentModification :: Maybe ([(String, String)] -> [(String, String)])
environmentModification = Maybe ([(String, String)] -> [(String, String)])
forall a. Maybe a
Nothing,
      workingDir :: Maybe String
workingDir = Maybe String
forall a. Maybe a
Nothing,
      throwOnError :: Bool
throwOnError = Bool
True,
      stdinConfig :: StdinConfig
stdinConfig = StdinConfig
InheritStdin,
      stdoutConfig :: OutputStreamConfig
stdoutConfig = OutputStreamConfig
defaultOutputStreamConfig,
      stderrConfig :: OutputStreamConfig
stderrConfig = OutputStreamConfig
defaultOutputStreamConfig,
      delegateCtlc :: Bool
delegateCtlc = Bool
False
    }

data ProcessResult = ProcessResult
  { ProcessResult -> ExitCode
exitCode :: ExitCode,
    ProcessResult -> Maybe ByteString
stdout :: Maybe ByteString,
    ProcessResult -> Maybe ByteString
stderr :: Maybe ByteString,
    ProcessResult -> ProcessConfiguration
processConfiguration :: ProcessConfiguration
  }

runProcess :: ProcessConfiguration -> IO ProcessResult
runProcess :: ProcessConfiguration -> IO ProcessResult
runProcess ProcessConfiguration
config = do
  IO ()
assertThreadedRuntime
  let stdoutHandler :: OutputStreamHandler
stdoutHandler = OutputStreamConfig -> OutputStreamHandler
outputStreamHandler (OutputStreamConfig -> OutputStreamHandler)
-> OutputStreamConfig -> OutputStreamHandler
forall a b. (a -> b) -> a -> b
$ ProcessConfiguration -> OutputStreamConfig
stdoutConfig ProcessConfiguration
config
      stderrHandler :: OutputStreamHandler
stderrHandler = OutputStreamConfig -> OutputStreamHandler
outputStreamHandler (OutputStreamConfig -> OutputStreamHandler)
-> OutputStreamConfig -> OutputStreamHandler
forall a b. (a -> b) -> a -> b
$ ProcessConfiguration -> OutputStreamConfig
stderrConfig ProcessConfiguration
config
  Maybe [(String, String)]
environment <- Maybe ([(String, String)] -> [(String, String)])
-> (([(String, String)] -> [(String, String)])
    -> IO [(String, String)])
-> IO (Maybe [(String, String)])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ProcessConfiguration
-> Maybe ([(String, String)] -> [(String, String)])
environmentModification ProcessConfiguration
config) ((([(String, String)] -> [(String, String)])
  -> IO [(String, String)])
 -> IO (Maybe [(String, String)]))
-> (([(String, String)] -> [(String, String)])
    -> IO [(String, String)])
-> IO (Maybe [(String, String)])
forall a b. (a -> b) -> a -> b
$ \[(String, String)] -> [(String, String)]
f -> do
    [(String, String)] -> [(String, String)]
f ([(String, String)] -> [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
  String
-> CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO ProcessResult)
-> IO ProcessResult
forall a.
String
-> CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess
    String
"Cradle.run"
    ( (String -> [String] -> CreateProcess
proc (ProcessConfiguration -> String
executable ProcessConfiguration
config) (ProcessConfiguration -> [String]
arguments ProcessConfiguration
config))
        { cwd = workingDir config,
          std_in = case stdinConfig config of
            StdinConfig
InheritStdin -> StdStream
Inherit
            UseStdinHandle Handle
handle -> Handle -> StdStream
UseHandle Handle
handle
            StdinConfig
NoStdinStream -> StdStream
NoStream,
          std_out = stdStream stdoutHandler,
          std_err = stdStream stderrHandler,
          delegate_ctlc = delegateCtlc config,
          env = environment
        }
    )
    ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO ProcessResult)
 -> IO ProcessResult)
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO ProcessResult)
-> IO ProcessResult
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
mStdout Maybe Handle
mStderr ProcessHandle
handle -> do
      IO (Maybe ByteString)
waitForStdoutCapture <- OutputStreamHandler -> Maybe Handle -> IO (IO (Maybe ByteString))
startCapturing OutputStreamHandler
stdoutHandler Maybe Handle
mStdout
      IO (Maybe ByteString)
waitForStderrCapture <- OutputStreamHandler -> Maybe Handle -> IO (IO (Maybe ByteString))
startCapturing OutputStreamHandler
stderrHandler Maybe Handle
mStderr
      ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
handle
      ProcessConfiguration -> ExitCode -> IO ()
throwWhenNonZero ProcessConfiguration
config ExitCode
exitCode
      Maybe ByteString
stdout <- IO (Maybe ByteString)
waitForStdoutCapture
      Maybe ByteString
stderr <- IO (Maybe ByteString)
waitForStderrCapture
      ProcessResult -> IO ProcessResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessResult -> IO ProcessResult)
-> ProcessResult -> IO ProcessResult
forall a b. (a -> b) -> a -> b
$
        ProcessResult
          { Maybe ByteString
stdout :: Maybe ByteString
stdout :: Maybe ByteString
stdout,
            Maybe ByteString
stderr :: Maybe ByteString
stderr :: Maybe ByteString
stderr,
            ExitCode
exitCode :: ExitCode
exitCode :: ExitCode
exitCode,
            processConfiguration :: ProcessConfiguration
processConfiguration = ProcessConfiguration
config
          }

withCreateProcess :: String -> CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a
withCreateProcess :: forall a.
String
-> CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess String
message CreateProcess
createProcess Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a
action =
  IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
message CreateProcess
createProcess)
    (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess
    (\(Maybe Handle
mStdin, Maybe Handle
mStdout, Maybe Handle
mStderr, ProcessHandle
processHandle) -> Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a
action Maybe Handle
mStdin Maybe Handle
mStdout Maybe Handle
mStderr ProcessHandle
processHandle)

data OutputStreamHandler = OutputStreamHandler
  { OutputStreamHandler -> StdStream
stdStream :: StdStream,
    OutputStreamHandler -> Maybe Handle -> IO (IO (Maybe ByteString))
startCapturing :: Maybe Handle -> IO (IO (Maybe ByteString))
  }

maxBufferSize :: Int
maxBufferSize :: Int
maxBufferSize = Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024

outputStreamHandler :: OutputStreamConfig -> OutputStreamHandler
outputStreamHandler :: OutputStreamConfig -> OutputStreamHandler
outputStreamHandler OutputStreamConfig
config =
  OutputStreamHandler
    { stdStream :: StdStream
stdStream = case OutputStreamConfig
config of
        OutputStreamConfig Bool
False Maybe [Handle]
Nothing -> StdStream
Inherit
        OutputStreamConfig Bool
False (Just [Handle
sink]) -> Handle -> StdStream
UseHandle Handle
sink
        OutputStreamConfig Bool
_ Maybe [Handle]
_ -> StdStream
CreatePipe,
      startCapturing :: Maybe Handle -> IO (IO (Maybe ByteString))
startCapturing = case OutputStreamConfig
config of
        OutputStreamConfig Bool
False Maybe [Handle]
Nothing -> IO (IO (Maybe ByteString))
-> Maybe Handle -> IO (IO (Maybe ByteString))
forall a. IO a -> Maybe Handle -> IO a
expectNoHandle (IO (IO (Maybe ByteString))
 -> Maybe Handle -> IO (IO (Maybe ByteString)))
-> IO (IO (Maybe ByteString))
-> Maybe Handle
-> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe ByteString) -> IO (IO (Maybe ByteString)))
-> IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
        OutputStreamConfig Bool
True Maybe [Handle]
Nothing -> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle -> IO (IO (Maybe ByteString))
forall a. (Handle -> IO a) -> Maybe Handle -> IO a
expectHandle ((Handle -> IO (IO (Maybe ByteString)))
 -> Maybe Handle -> IO (IO (Maybe ByteString)))
-> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle
-> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
          MVar ByteString
mvar <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
          ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
hGetContents Handle
handle IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
mvar
          IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe ByteString) -> IO (IO (Maybe ByteString)))
-> IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
readMVar MVar ByteString
mvar
        OutputStreamConfig Bool
False (Just []) -> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle -> IO (IO (Maybe ByteString))
forall a. (Handle -> IO a) -> Maybe Handle -> IO a
expectHandle ((Handle -> IO (IO (Maybe ByteString)))
 -> Maybe Handle -> IO (IO (Maybe ByteString)))
-> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle
-> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ \Handle
_handle -> IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe ByteString) -> IO (IO (Maybe ByteString)))
-> IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
        OutputStreamConfig Bool
False (Just [Handle
_sink]) -> IO (IO (Maybe ByteString))
-> Maybe Handle -> IO (IO (Maybe ByteString))
forall a. IO a -> Maybe Handle -> IO a
expectNoHandle (IO (IO (Maybe ByteString))
 -> Maybe Handle -> IO (IO (Maybe ByteString)))
-> IO (IO (Maybe ByteString))
-> Maybe Handle
-> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe ByteString) -> IO (IO (Maybe ByteString)))
-> IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
        OutputStreamConfig Bool
False (Just [Handle]
sinks) -> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle -> IO (IO (Maybe ByteString))
forall a. (Handle -> IO a) -> Maybe Handle -> IO a
expectHandle ((Handle -> IO (IO (Maybe ByteString)))
 -> Maybe Handle -> IO (IO (Maybe ByteString)))
-> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle
-> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
          MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
          ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
            let loop :: IO ()
loop = do
                  ByteString
chunk <- Handle -> Int -> IO ByteString
hGetSome Handle
handle Int
maxBufferSize
                  if ByteString -> Bool
Data.ByteString.null ByteString
chunk
                    then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else do
                      [Handle] -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Handle]
sinks ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
sink -> Handle -> ByteString -> IO ()
hPut Handle
sink ByteString
chunk
                      IO ()
loop
            IO ()
loop
            MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
          IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe ByteString) -> IO (IO (Maybe ByteString)))
-> IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ do
            MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
mvar
            Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
        OutputStreamConfig Bool
True (Just [Handle]
sinks) -> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle -> IO (IO (Maybe ByteString))
forall a. (Handle -> IO a) -> Maybe Handle -> IO a
expectHandle ((Handle -> IO (IO (Maybe ByteString)))
 -> Maybe Handle -> IO (IO (Maybe ByteString)))
-> (Handle -> IO (IO (Maybe ByteString)))
-> Maybe Handle
-> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
          MVar ByteString
mvar <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
          ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
            let loop :: ByteString -> IO ByteString
loop ByteString
acc = do
                  ByteString
chunk <- Handle -> Int -> IO ByteString
hGetSome Handle
handle Int
maxBufferSize
                  if ByteString -> Bool
Data.ByteString.null ByteString
chunk
                    then ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
acc
                    else do
                      [Handle] -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Handle]
sinks ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
sink -> Handle -> ByteString -> IO ()
hPut Handle
sink ByteString
chunk
                      ByteString -> IO ByteString
loop (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
chunk
            ByteString -> IO ByteString
loop ByteString
forall a. Monoid a => a
mempty IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
mvar
          IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe ByteString) -> IO (IO (Maybe ByteString)))
-> IO (Maybe ByteString) -> IO (IO (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
readMVar MVar ByteString
mvar
    }
  where
    expectNoHandle :: IO a -> Maybe Handle -> IO a
    expectNoHandle :: forall a. IO a -> Maybe Handle -> IO a
expectNoHandle IO a
action = \case
      Just Handle
_ -> ErrorCall -> IO a
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO a) -> ErrorCall -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"outputStreamHandler: pipe created unexpectedly"
      Maybe Handle
Nothing -> IO a
action

    expectHandle :: (Handle -> IO a) -> Maybe Handle -> IO a
    expectHandle :: forall a. (Handle -> IO a) -> Maybe Handle -> IO a
expectHandle Handle -> IO a
action = \case
      Maybe Handle
Nothing -> ErrorCall -> IO a
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO a) -> ErrorCall -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"outputStreamHandler: pipe not created unexpectedly"
      Just Handle
handle -> Handle -> IO a
action Handle
handle

assertThreadedRuntime :: IO ()
assertThreadedRuntime :: IO ()
assertThreadedRuntime =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
hostIsThreaded) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO ()) -> ErrorCall -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cradle needs the ghc's threaded runtime system to work correctly. Use the ghc option '-threaded'."

throwWhenNonZero :: ProcessConfiguration -> ExitCode -> IO ()
throwWhenNonZero :: ProcessConfiguration -> ExitCode -> IO ()
throwWhenNonZero ProcessConfiguration
config ExitCode
exitCode = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProcessConfiguration -> Bool
throwOnError ProcessConfiguration
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    case ExitCode
exitCode of
      ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitFailure Int
exitCode -> do
        ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO ()) -> ErrorCall -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$
            String
"command failed with exitcode "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
exitCode
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ProcessConfiguration -> String
executable ProcessConfiguration
config