{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Cli.Extras.Process
( AsProcessFailure (..)
, ProcessFailure (..)
, ProcessSpec (..)
, callCommand
, callProcess
, callProcessAndLogOutput
, createProcess
, createProcess_
, overCreateProcess
, proc
, readCreateProcessWithExitCode
, readProcessAndLogOutput
, readProcessAndLogStderr
, readProcessJSONAndLogStderr
, reconstructCommand
, setCwd
, setDelegateCtlc
, setEnvOverride
, shell
, waitForProcess
, prettyProcessFailure
) where
import Control.Monad ((<=<), join, void)
import Control.Monad.Except (throwError)
import Control.Monad.Fail
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 Data.Function (fix)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
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 qualified Data.Aeson as Aeson
import Control.Monad.Log (Severity (..))
import Cli.Extras.Logging (putLog, putLogRaw)
import Cli.Extras.Types (CliLog, CliThrow)
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
prettyProcessFailure :: ProcessFailure -> Text
prettyProcessFailure :: ProcessFailure -> Text
prettyProcessFailure (ProcessFailure p :: CmdSpec
p code :: Int
code) = "Process exited with code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
code) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CmdSpec -> Text
reconstructCommand CmdSpec
p
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, MonadFail 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,
MonadFail 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, MonadFail 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,
MonadFail 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, CliThrow e m, AsProcessFailure e)
=> 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
ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
p m ExitCode -> (ExitCode -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ExitSuccess -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
outText
ExitFailure code :: Int
code -> e -> m Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m Text) -> e -> m Text
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) Int
code
callProcessAndLogOutput
:: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail 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,
MonadFail 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') = do
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, MonadFail 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 = 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
(\x :: CreateProcess
x -> CreateProcess
x { std_out :: StdStream
std_out = StdStream
CreatePipe , std_err :: StdStream
std_err = StdStream
CreatePipe }) ProcessSpec
process
Handle -> Handle -> m ()
f Handle
out Handle
err
ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
p m ExitCode
-> (ExitCode -> m (Handle, Handle)) -> m (Handle, Handle)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ExitSuccess -> (Handle, Handle) -> m (Handle, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
out, Handle
err)
ExitFailure code :: Int
code -> e -> m (Handle, Handle)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m (Handle, Handle)) -> e -> m (Handle, Handle)
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) Int
code
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
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 = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
quoteAndEscape (String
cmd String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args)
quoteAndEscape :: String -> Text
quoteAndEscape x :: String
x = "'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
T.replace "'" "'\''" (String -> Text
T.pack String
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "'"
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