{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
module Cli.Extras.Process
( AsProcessFailure (..)
, ProcessFailure (..)
, ProcessSpec (..)
, callCommand
, callProcess
, callProcessAndLogOutput
, createProcess
, createProcess_
, throwExitCode
, overCreateProcess
, proc
, readCreateProcessWithExitCode
, readProcessAndLogOutput
, readProcessAndLogStderr
, readProcessJSONAndLogStderr
, reconstructCommand
, runProcess_
, setCwd
, setDelegateCtlc
, setEnvOverride
, shell
, waitForProcess
, runProc
, runProcSilently
, readProc
) where
import Control.Monad ((<=<), join, void)
import Control.Monad.Catch (MonadMask, bracketOnError)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Lens (Prism', review)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.UTF8 as BSU
import Data.Function (fix)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Encoding.Error (lenientDecode)
import System.Environment (getEnvironment)
import System.Exit (ExitCode (..))
import System.IO (Handle)
import System.IO.Streams (InputStream, handleToInputStream)
import qualified System.IO.Streams as Streams
import System.IO.Streams.Concurrent (concurrentMerge)
import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), std_err, std_out)
import qualified System.Process as Process
import Text.ShellEscape (bash, bytes)
import qualified Data.Aeson as Aeson
import Control.Monad.Log (Severity (..))
import Cli.Extras.Logging (putLog, putLogRaw)
import Cli.Extras.Types (CliLog, CliThrow)
#if !(MIN_VERSION_base(4, 13, 0))
import Control.Monad.Fail (MonadFail)
#endif
data ProcessSpec = ProcessSpec
{ ProcessSpec -> CreateProcess
_processSpec_createProcess :: !CreateProcess
, ProcessSpec -> Maybe (Map String String -> Map String String)
_processSpec_overrideEnv :: !(Maybe (Map String String -> Map String String))
}
proc :: FilePath -> [String] -> ProcessSpec
proc :: String -> [String] -> ProcessSpec
proc cmd :: String
cmd args :: [String]
args = CreateProcess
-> Maybe (Map String String -> Map String String) -> ProcessSpec
ProcessSpec (String -> [String] -> CreateProcess
Process.proc String
cmd [String]
args) Maybe (Map String String -> Map String String)
forall a. Maybe a
Nothing
shell :: String -> ProcessSpec
shell :: String -> ProcessSpec
shell cmd :: String
cmd = CreateProcess
-> Maybe (Map String String -> Map String String) -> ProcessSpec
ProcessSpec (String -> CreateProcess
Process.shell String
cmd) Maybe (Map String String -> Map String String)
forall a. Maybe a
Nothing
setEnvOverride :: (Map String String -> Map String String) -> ProcessSpec -> ProcessSpec
setEnvOverride :: (Map String String -> Map String String)
-> ProcessSpec -> ProcessSpec
setEnvOverride f :: Map String String -> Map String String
f p :: ProcessSpec
p = ProcessSpec
p { _processSpec_overrideEnv :: Maybe (Map String String -> Map String String)
_processSpec_overrideEnv = (Map String String -> Map String String)
-> Maybe (Map String String -> Map String String)
forall a. a -> Maybe a
Just Map String String -> Map String String
f }
overCreateProcess :: (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess :: (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess f :: CreateProcess -> CreateProcess
f (ProcessSpec p :: CreateProcess
p x :: Maybe (Map String String -> Map String String)
x) = CreateProcess
-> Maybe (Map String String -> Map String String) -> ProcessSpec
ProcessSpec (CreateProcess -> CreateProcess
f CreateProcess
p) Maybe (Map String String -> Map String String)
x
setDelegateCtlc :: Bool -> ProcessSpec -> ProcessSpec
setDelegateCtlc :: Bool -> ProcessSpec -> ProcessSpec
setDelegateCtlc b :: Bool
b = (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess (\p :: CreateProcess
p -> CreateProcess
p { delegate_ctlc :: Bool
Process.delegate_ctlc = Bool
b })
setCwd :: Maybe FilePath -> ProcessSpec -> ProcessSpec
setCwd :: Maybe String -> ProcessSpec -> ProcessSpec
setCwd fp :: Maybe String
fp = (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess (\p :: CreateProcess
p -> CreateProcess
p { cwd :: Maybe String
Process.cwd = Maybe String
fp })
data ProcessFailure = ProcessFailure Process.CmdSpec Int
deriving Int -> ProcessFailure -> ShowS
[ProcessFailure] -> ShowS
ProcessFailure -> String
(Int -> ProcessFailure -> ShowS)
-> (ProcessFailure -> String)
-> ([ProcessFailure] -> ShowS)
-> Show ProcessFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProcessFailure] -> ShowS
$cshowList :: [ProcessFailure] -> ShowS
show :: ProcessFailure -> String
$cshow :: ProcessFailure -> String
showsPrec :: Int -> ProcessFailure -> ShowS
$cshowsPrec :: Int -> ProcessFailure -> ShowS
Show
class AsProcessFailure e where
asProcessFailure :: Prism' e ProcessFailure
instance AsProcessFailure ProcessFailure where
asProcessFailure :: p ProcessFailure (f ProcessFailure)
-> p ProcessFailure (f ProcessFailure)
asProcessFailure = p ProcessFailure (f ProcessFailure)
-> p ProcessFailure (f ProcessFailure)
forall a. a -> a
id
readProcessAndLogStderr
:: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)
=> Severity -> ProcessSpec -> m Text
readProcessAndLogStderr :: Severity -> ProcessSpec -> m Text
readProcessAndLogStderr sev :: Severity
sev process :: ProcessSpec
process = do
(out :: Handle
out, _err :: Handle
_err) <- ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadMask m) =>
ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
withProcess ProcessSpec
process ((Handle -> Handle -> m ()) -> m (Handle, Handle))
-> (Handle -> Handle -> m ()) -> m (Handle, Handle)
forall a b. (a -> b) -> a -> b
$ \_out :: Handle
_out err :: Handle
err -> do
InputStream (Severity, ByteString) -> m ()
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
InputStream (Severity, ByteString) -> m ()
streamToLog (InputStream (Severity, ByteString) -> m ())
-> m (InputStream (Severity, ByteString)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (InputStream (Severity, ByteString))
-> m (InputStream (Severity, ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle Severity
sev Handle
err)
IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BS.hGetContents Handle
out
readProcessJSONAndLogStderr
:: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)
=> Severity -> ProcessSpec -> m a
readProcessJSONAndLogStderr :: Severity -> ProcessSpec -> m a
readProcessJSONAndLogStderr sev :: Severity
sev process :: ProcessSpec
process = do
(out :: Handle
out, _err :: Handle
_err) <- ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadMask m) =>
ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
withProcess ProcessSpec
process ((Handle -> Handle -> m ()) -> m (Handle, Handle))
-> (Handle -> Handle -> m ()) -> m (Handle, Handle)
forall a b. (a -> b) -> a -> b
$ \_out :: Handle
_out err :: Handle
err -> do
InputStream (Severity, ByteString) -> m ()
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
InputStream (Severity, ByteString) -> m ()
streamToLog (InputStream (Severity, ByteString) -> m ())
-> m (InputStream (Severity, ByteString)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (InputStream (Severity, ByteString))
-> m (InputStream (Severity, ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle Severity
sev Handle
err)
ByteString
json <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
BS.hGetContents Handle
out
case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
json of
Right a :: a
a -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left err :: String
err -> do
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Error (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Could not decode process output as JSON: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err
e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m a) -> e -> m a
forall a b. (a -> b) -> a -> b
$ AReview e ProcessFailure -> ProcessFailure -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e ProcessFailure
forall e. AsProcessFailure e => Prism' e ProcessFailure
asProcessFailure (ProcessFailure -> e) -> ProcessFailure -> e
forall a b. (a -> b) -> a -> b
$ CmdSpec -> Int -> ProcessFailure
ProcessFailure (CreateProcess -> CmdSpec
Process.cmdspec (CreateProcess -> CmdSpec) -> CreateProcess -> CmdSpec
forall a b. (a -> b) -> a -> b
$ ProcessSpec -> CreateProcess
_processSpec_createProcess ProcessSpec
process) 0
readCreateProcessWithExitCode
:: (MonadIO m, CliLog m)
=> ProcessSpec -> m (ExitCode, String, String)
readCreateProcessWithExitCode :: ProcessSpec -> m (ExitCode, String, String)
readCreateProcessWithExitCode procSpec :: ProcessSpec
procSpec = do
CreateProcess
process <- ProcessSpec -> m CreateProcess
forall (m :: * -> *). MonadIO m => ProcessSpec -> m CreateProcess
mkCreateProcess ProcessSpec
procSpec
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Creating process: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProcessSpec -> Text
reconstructProcSpec ProcessSpec
procSpec
IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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)
Process.readCreateProcessWithExitCode CreateProcess
process ""
readProcessAndLogOutput
:: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
=> (Severity, Severity)
-> ProcessSpec
-> m Text
readProcessAndLogOutput :: (Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (sev_out :: Severity
sev_out, sev_err :: Severity
sev_err) process :: ProcessSpec
process = do
(_, Just out :: Handle
out, Just err :: Handle
err, p :: ProcessHandle
p) <- ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess
(\p :: CreateProcess
p -> CreateProcess
p { std_out :: StdStream
std_out = StdStream
CreatePipe , std_err :: StdStream
std_err = StdStream
CreatePipe }) ProcessSpec
process
InputStream (Severity, ByteString) -> m ()
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
InputStream (Severity, ByteString) -> m ()
streamToLog (InputStream (Severity, ByteString) -> m ())
-> m (InputStream (Severity, ByteString)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (InputStream (Severity, ByteString))
-> m (InputStream (Severity, ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle Severity
sev_err Handle
err)
Text
outText <- IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BS.hGetContents Handle
out
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLogRaw Severity
sev_out Text
outText
Text
outText Text -> m () -> m Text
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ProcessSpec -> ExitCode -> m ()
forall e (m :: * -> *).
(CliThrow e m, AsProcessFailure e) =>
ProcessSpec -> ExitCode -> m ()
throwExitCode ProcessSpec
process (ExitCode -> m ()) -> m ExitCode -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
p)
callProcessAndLogOutput
:: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)
=> (Severity, Severity)
-> ProcessSpec
-> m ()
callProcessAndLogOutput :: (Severity, Severity) -> ProcessSpec -> m ()
callProcessAndLogOutput (sev_out :: Severity
sev_out, sev_err :: Severity
sev_err) process :: ProcessSpec
process =
m (Handle, Handle) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Handle, Handle) -> m ()) -> m (Handle, Handle) -> m ()
forall a b. (a -> b) -> a -> b
$ ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadMask m) =>
ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
withProcess ProcessSpec
process ((Handle -> Handle -> m ()) -> m (Handle, Handle))
-> (Handle -> Handle -> m ()) -> m (Handle, Handle)
forall a b. (a -> b) -> a -> b
$ \out :: Handle
out err :: Handle
err -> do
InputStream (Severity, ByteString)
stream <- IO (InputStream (Severity, ByteString))
-> m (InputStream (Severity, ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream (Severity, ByteString))
-> m (InputStream (Severity, ByteString)))
-> IO (InputStream (Severity, ByteString))
-> m (InputStream (Severity, ByteString))
forall a b. (a -> b) -> a -> b
$ IO (IO (InputStream (Severity, ByteString)))
-> IO (InputStream (Severity, ByteString))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (InputStream (Severity, ByteString)))
-> IO (InputStream (Severity, ByteString)))
-> IO (IO (InputStream (Severity, ByteString)))
-> IO (InputStream (Severity, ByteString))
forall a b. (a -> b) -> a -> b
$ InputStream (Severity, ByteString)
-> InputStream (Severity, ByteString)
-> IO (InputStream (Severity, ByteString))
forall a. InputStream a -> InputStream a -> IO (InputStream a)
combineStream
(InputStream (Severity, ByteString)
-> InputStream (Severity, ByteString)
-> IO (InputStream (Severity, ByteString)))
-> IO (InputStream (Severity, ByteString))
-> IO
(InputStream (Severity, ByteString)
-> IO (InputStream (Severity, ByteString)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle Severity
sev_out Handle
out
IO
(InputStream (Severity, ByteString)
-> IO (InputStream (Severity, ByteString)))
-> IO (InputStream (Severity, ByteString))
-> IO (IO (InputStream (Severity, ByteString)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle Severity
sev_err Handle
err
InputStream (Severity, ByteString) -> m ()
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
InputStream (Severity, ByteString) -> m ()
streamToLog InputStream (Severity, ByteString)
stream
where
combineStream :: InputStream a -> InputStream a -> IO (InputStream a)
combineStream s1 :: InputStream a
s1 s2 :: InputStream a
s2 = [InputStream a] -> IO (InputStream a)
forall a. [InputStream a] -> IO (InputStream a)
concurrentMerge [InputStream a
s1, InputStream a
s2]
createProcess
:: (MonadIO m, CliLog m)
=> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess :: ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess procSpec :: ProcessSpec
procSpec = do
CreateProcess
p <- ProcessSpec -> m CreateProcess
forall (m :: * -> *). MonadIO m => ProcessSpec -> m CreateProcess
mkCreateProcess ProcessSpec
procSpec
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Creating process: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProcessSpec -> Text
reconstructProcSpec ProcessSpec
procSpec
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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)
Process.createProcess CreateProcess
p
createProcess_
:: (MonadIO m, CliLog m)
=> String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ :: String
-> ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ name :: String
name procSpec :: ProcessSpec
procSpec = do
CreateProcess
p <- ProcessSpec -> m CreateProcess
forall (m :: * -> *). MonadIO m => ProcessSpec -> m CreateProcess
mkCreateProcess ProcessSpec
procSpec
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Creating process " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProcessSpec -> Text
reconstructProcSpec ProcessSpec
procSpec
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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
$ String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess_ String
name CreateProcess
p
mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess
mkCreateProcess :: ProcessSpec -> m CreateProcess
mkCreateProcess (ProcessSpec p :: CreateProcess
p override' :: Maybe (Map String String -> Map String String)
override') = case Maybe (Map String String -> Map String String)
override' of
Nothing -> CreateProcess -> m CreateProcess
forall (f :: * -> *) a. Applicative f => a -> f a
pure CreateProcess
p
Just override :: Map String String -> Map String String
override -> do
Map String String
procEnv <- [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, String)] -> Map String String)
-> m [(String, String)] -> m (Map String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [(String, String)]
-> ([(String, String)] -> m [(String, String)])
-> Maybe [(String, String)]
-> m [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO [(String, String)] -> m [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment) [(String, String)] -> m [(String, String)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> Maybe [(String, String)]
Process.env CreateProcess
p)
CreateProcess -> m CreateProcess
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> m CreateProcess)
-> CreateProcess -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ CreateProcess
p { env :: Maybe [(String, String)]
Process.env = [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just ([(String, String)] -> Maybe [(String, String)])
-> [(String, String)] -> Maybe [(String, String)]
forall a b. (a -> b) -> a -> b
$ Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map String String -> Map String String
override Map String String
procEnv) }
callProcess
:: (MonadIO m, CliLog m)
=> String -> [String] -> m ()
callProcess :: String -> [String] -> m ()
callProcess exe :: String
exe args :: [String]
args = do
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Calling process " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
exe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " with args: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([String] -> String
forall a. Show a => a -> String
show [String]
args)
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ()
Process.callProcess String
exe [String]
args
callCommand
:: (MonadIO m, CliLog m)
=> String -> m ()
callCommand :: String -> m ()
callCommand cmd :: String
cmd = do
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Calling command " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
cmd
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
Process.callCommand String
cmd
withProcess
:: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)
=> ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
withProcess :: ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
withProcess process :: ProcessSpec
process f :: Handle -> Handle -> m ()
f =
m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Handle, Handle))
-> m (Handle, Handle)
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracketOnError
(ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess
(\x :: CreateProcess
x -> CreateProcess
x { std_out :: StdStream
std_out = StdStream
CreatePipe , std_err :: StdStream
std_err = StdStream
CreatePipe }) ProcessSpec
process
)
(IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ())
-> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
Process.cleanupProcess)
(\case
(_, Just out :: Handle
out, Just err :: Handle
err, p :: ProcessHandle
p) -> do
Handle -> Handle -> m ()
f Handle
out Handle
err
(Handle
out, Handle
err) (Handle, Handle) -> m () -> m (Handle, Handle)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ProcessSpec -> ExitCode -> m ()
forall e (m :: * -> *).
(CliThrow e m, AsProcessFailure e) =>
ProcessSpec -> ExitCode -> m ()
throwExitCode ProcessSpec
process (ExitCode -> m ()) -> m ExitCode -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
p)
_ -> String -> m (Handle, Handle)
forall a. HasCallStack => String -> a
error "withProcess: createProcess did not provide handles for CreatePipe as expected"
)
runProcess_
:: (MonadIO m, CliLog m, CliThrow e m, MonadMask m, AsProcessFailure e)
=> ProcessSpec -> m ()
runProcess_ :: ProcessSpec -> m ()
runProcess_ process :: ProcessSpec
process =
m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m ())
-> m ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracketOnError
(ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ProcessSpec
process)
(IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ())
-> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
Process.cleanupProcess)
(\(_, _, _, ph :: ProcessHandle
ph) -> ProcessSpec -> ExitCode -> m ()
forall e (m :: * -> *).
(CliThrow e m, AsProcessFailure e) =>
ProcessSpec -> ExitCode -> m ()
throwExitCode ProcessSpec
process (ExitCode -> m ()) -> m ExitCode -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
ph)
streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))
streamHandle :: Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle sev :: Severity
sev = (ByteString -> (Severity, ByteString))
-> InputStream ByteString
-> IO (InputStream (Severity, ByteString))
forall a b. (a -> b) -> InputStream a -> IO (InputStream b)
Streams.map (Severity
sev,) (InputStream ByteString -> IO (InputStream (Severity, ByteString)))
-> (Handle -> IO (InputStream ByteString))
-> Handle
-> IO (InputStream (Severity, ByteString))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Handle -> IO (InputStream ByteString)
handleToInputStream
streamToLog
:: (MonadIO m, CliLog m)
=> InputStream (Severity, BSC.ByteString) -> m ()
streamToLog :: InputStream (Severity, ByteString) -> m ()
streamToLog stream :: InputStream (Severity, ByteString)
stream = (m () -> m ()) -> m ()
forall a. (a -> a) -> a
fix ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \loop :: m ()
loop -> do
IO (Maybe (Severity, ByteString))
-> m (Maybe (Severity, ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (InputStream (Severity, ByteString)
-> IO (Maybe (Severity, ByteString))
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream (Severity, ByteString)
stream) m (Maybe (Severity, ByteString))
-> (Maybe (Severity, ByteString) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (sev :: Severity
sev, line :: ByteString
line) -> Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLogRaw Severity
sev (OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
lenientDecode ByteString
line) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
loop
waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode
waitForProcess :: ProcessHandle -> m ExitCode
waitForProcess = IO ExitCode -> m ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> m ExitCode)
-> (ProcessHandle -> IO ExitCode) -> ProcessHandle -> m ExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessHandle -> IO ExitCode
Process.waitForProcess
throwExitCode :: (CliThrow e m, AsProcessFailure e) => ProcessSpec -> ExitCode -> m ()
throwExitCode :: ProcessSpec -> ExitCode -> m ()
throwExitCode spec :: ProcessSpec
spec = \case
ExitSuccess -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ExitFailure code :: Int
code -> e -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m ()) -> e -> m ()
forall a b. (a -> b) -> a -> b
$ AReview e ProcessFailure -> ProcessFailure -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e ProcessFailure
forall e. AsProcessFailure e => Prism' e ProcessFailure
asProcessFailure (ProcessFailure -> e) -> ProcessFailure -> e
forall a b. (a -> b) -> a -> b
$ CmdSpec -> Int -> ProcessFailure
ProcessFailure (CreateProcess -> CmdSpec
Process.cmdspec (CreateProcess -> CmdSpec) -> CreateProcess -> CmdSpec
forall a b. (a -> b) -> a -> b
$ ProcessSpec -> CreateProcess
_processSpec_createProcess ProcessSpec
spec) Int
code
reconstructCommand :: Process.CmdSpec -> Text
reconstructCommand :: CmdSpec -> Text
reconstructCommand p :: CmdSpec
p = case CmdSpec
p of
Process.ShellCommand str :: String
str -> String -> Text
T.pack String
str
Process.RawCommand c :: String
c as :: [String]
as -> String -> [String] -> Text
processToShellString String
c [String]
as
where
processToShellString :: String -> [String] -> Text
processToShellString cmd :: String
cmd args :: [String]
args = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
BSU.toString (ByteString -> String) -> (String -> ByteString) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bash -> ByteString
forall t. Escape t => t -> ByteString
bytes (Bash -> ByteString) -> (String -> Bash) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bash
bash (ByteString -> Bash) -> (String -> ByteString) -> String -> Bash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BSU.fromString) (String
cmd String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args)
reconstructProcSpec :: ProcessSpec -> Text
reconstructProcSpec :: ProcessSpec -> Text
reconstructProcSpec = CmdSpec -> Text
reconstructCommand (CmdSpec -> Text)
-> (ProcessSpec -> CmdSpec) -> ProcessSpec -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateProcess -> CmdSpec
Process.cmdspec (CreateProcess -> CmdSpec)
-> (ProcessSpec -> CreateProcess) -> ProcessSpec -> CmdSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessSpec -> CreateProcess
_processSpec_createProcess
runProc
:: ( MonadIO m
, CliLog m
, CliThrow e m
, AsProcessFailure e
, MonadFail m
, MonadMask m
)
=> ProcessSpec -> m ()
runProc :: ProcessSpec -> m ()
runProc = (Severity, Severity) -> ProcessSpec -> m ()
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadMask m) =>
(Severity, Severity) -> ProcessSpec -> m ()
callProcessAndLogOutput (Severity
Notice, Severity
Error)
runProcSilently
:: ( MonadIO m
, CliLog m
, CliThrow e m
, AsProcessFailure e
, MonadFail m
, MonadMask m
)
=> ProcessSpec -> m ()
runProcSilently :: ProcessSpec -> m ()
runProcSilently = (Severity, Severity) -> ProcessSpec -> m ()
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadMask m) =>
(Severity, Severity) -> ProcessSpec -> m ()
callProcessAndLogOutput (Severity
Debug, Severity
Debug)
readProc
:: ( MonadIO m
, CliLog m
, CliThrow e m
, AsProcessFailure e
, MonadFail m
)
=> ProcessSpec -> m Text
readProc :: ProcessSpec -> m Text
readProc = (Severity, Severity) -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadFail m) =>
(Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (Severity
Debug, Severity
Error)