{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}

-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)
-- and is thus spinner friendly.
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 String
cmd [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 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 Map String String -> Map String String
f ProcessSpec
p = ProcessSpec
p { _processSpec_overrideEnv = Just f }

overCreateProcess :: (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess :: (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess CreateProcess -> CreateProcess
f (ProcessSpec CreateProcess
p 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 Bool
b = (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess (\CreateProcess
p -> CreateProcess
p { Process.delegate_ctlc = b })

setCwd :: Maybe FilePath -> ProcessSpec -> ProcessSpec
setCwd :: Maybe String -> ProcessSpec -> ProcessSpec
setCwd Maybe String
fp = (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
overCreateProcess (\CreateProcess
p -> CreateProcess
p { Process.cwd = fp })


-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions
data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code
  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
$cshowsPrec :: Int -> ProcessFailure -> ShowS
showsPrec :: Int -> ProcessFailure -> ShowS
$cshow :: ProcessFailure -> String
show :: ProcessFailure -> String
$cshowList :: [ProcessFailure] -> ShowS
showList :: [ProcessFailure] -> ShowS
Show

-- | Indicates arbitrary process failures form one variant (or conceptual projection) of
-- the error type.
class AsProcessFailure e where
  asProcessFailure :: Prism' e ProcessFailure

instance AsProcessFailure ProcessFailure where
  asProcessFailure :: Prism' ProcessFailure 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 :: forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadMask m) =>
Severity -> ProcessSpec -> m Text
readProcessAndLogStderr Severity
sev ProcessSpec
process = do
  (out, _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
$ \Handle
_out 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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle Severity
sev Handle
err)
  liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out

readProcessJSONAndLogStderr
  :: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)
  => Severity -> ProcessSpec -> m a
readProcessJSONAndLogStderr :: forall a (m :: * -> *) e.
(FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadMask m) =>
Severity -> ProcessSpec -> m a
readProcessJSONAndLogStderr Severity
sev ProcessSpec
process = do
  (out, _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
$ \Handle
_out 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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle Severity
sev Handle
err)
  json <- liftIO $ BS.hGetContents out
  case Aeson.eitherDecodeStrict json of
    Right a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left 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
$ Text
"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 a. 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
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
0

readCreateProcessWithExitCode
  :: (MonadIO m, CliLog m)
  => ProcessSpec -> m (ExitCode, String, String)
readCreateProcessWithExitCode :: forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec -> m (ExitCode, String, String)
readCreateProcessWithExitCode ProcessSpec
procSpec = do
  process <- ProcessSpec -> m CreateProcess
forall (m :: * -> *). MonadIO m => ProcessSpec -> m CreateProcess
mkCreateProcess ProcessSpec
procSpec
  putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec
  liftIO $ Process.readCreateProcessWithExitCode process ""

-- | Like 'System.Process.readProcess', but such that each of the child
-- processes' standard output streams (stdout and stderr) is logged,
-- with the corresponding severity.
--
-- Usually, this function is called as @readProcessAndLogOutput (Debug,
-- Error)@. If the child process is known to print diagnostic or
-- informative messages to stderr, it is advisable to call
-- 'readProcessAndLogOutput' with a non-Error severity for stderr, for
-- example @readProcessAndLogOutput (Debug, Debug)@.
readProcessAndLogOutput
  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
  => (Severity, Severity)
  -- ^ This tuple controls the severity of each output stream. Its @fst@
  -- is the severity of stdout; @snd@ is the severity of stderr.
  -> ProcessSpec
  -> m Text
readProcessAndLogOutput :: forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m) =>
(Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (Severity
sev_out, Severity
sev_err) ProcessSpec
process = do
  (_, Just out, Just err, 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
    (\CreateProcess
p -> CreateProcess
p { std_out = CreatePipe , std_err = CreatePipe }) ProcessSpec
process

  -- TODO interleave stdout and stderr in log correctly
  streamToLog =<< liftIO (streamHandle sev_err err)
  outText <- liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out
  putLogRaw sev_out outText

  outText <$ (throwExitCode process =<< waitForProcess p)

-- | Like 'System.Process.readProcess', but such that each of the child
-- processes' standard output streams (stdout and stderr) is logged,
-- with the corresponding severity.
--
-- Usually, this function is called as @callProcessAndLogOutput (Debug,
-- Error)@. If the child process is known to print diagnostic or
-- informative messages to stderr, it is advisable to call
-- 'callProcessAndLogOutput' with a non-Error severity for stderr, for
-- example @callProcessAndLogOutput (Debug, Debug)@.
callProcessAndLogOutput
  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)
  => (Severity, Severity)
  -- ^ This tuple controls the severity of each output stream. Its @fst@
  -- is the severity of stdout; @snd@ is the severity of stderr.
  -> ProcessSpec
  -> m ()
callProcessAndLogOutput :: forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadMask m) =>
(Severity, Severity) -> ProcessSpec -> m ()
callProcessAndLogOutput (Severity
sev_out, Severity
sev_err) 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
$ \Handle
out Handle
err -> do
    stream <- IO (InputStream (Severity, ByteString))
-> m (InputStream (Severity, ByteString))
forall a. IO a -> m a
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 a b. IO (a -> b) -> IO a -> IO b
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
    streamToLog stream
  where
    combineStream :: InputStream a -> InputStream a -> IO (InputStream a)
combineStream InputStream a
s1 InputStream a
s2 = [InputStream a] -> IO (InputStream a)
forall a. [InputStream a] -> IO (InputStream a)
concurrentMerge [InputStream a
s1, InputStream a
s2]

-- | Like 'System.Process.createProcess', but logging (with 'Debug'
-- severity) the process which was started.
createProcess
  :: (MonadIO m, CliLog m)
  => ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess :: forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ProcessSpec
procSpec = do
  p <- ProcessSpec -> m CreateProcess
forall (m :: * -> *). MonadIO m => ProcessSpec -> m CreateProcess
mkCreateProcess ProcessSpec
procSpec
  putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec
  liftIO $ Process.createProcess p

-- | Like 'System.Process.createProcess_', but logging (with 'Debug'
-- severity) the process which was started.
createProcess_
  :: (MonadIO m, CliLog m)
  => String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ :: forall (m :: * -> *).
(MonadIO m, CliLog m) =>
String
-> ProcessSpec
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
name ProcessSpec
procSpec = do
  p <- ProcessSpec -> m CreateProcess
forall (m :: * -> *). MonadIO m => ProcessSpec -> m CreateProcess
mkCreateProcess ProcessSpec
procSpec
  putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructProcSpec procSpec
  liftIO $ Process.createProcess_ name p

mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess
mkCreateProcess :: forall (m :: * -> *). MonadIO m => ProcessSpec -> m CreateProcess
mkCreateProcess (ProcessSpec CreateProcess
p Maybe (Map String String -> Map String String)
override') = case Maybe (Map String String -> Map String String)
override' of
  Maybe (Map String String -> Map String String)
Nothing -> CreateProcess -> m CreateProcess
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CreateProcess
p
  Just Map String String -> Map String String
override -> do
    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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment) [(String, String)] -> m [(String, String)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> Maybe [(String, String)]
Process.env CreateProcess
p)
    pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }

-- | Like 'System.Process.callProcess', but logging (with 'Debug'
-- severity) the process which was started.
callProcess
  :: (MonadIO m, CliLog m)
  => String -> [String] -> m ()
callProcess :: forall (m :: * -> *).
(MonadIO m, CliLog m) =>
String -> [String] -> m ()
callProcess String
exe [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
$ Text
"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
<> Text
" 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 a. IO a -> m a
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

-- | Like 'System.Process.callCommand', but logging (with 'Debug'
-- severity) the process which was started.
callCommand
  :: (MonadIO m, CliLog m)
  => String -> m ()
callCommand :: forall (m :: * -> *). (MonadIO m, CliLog m) => String -> m ()
callCommand 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
$ Text
"Calling command " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
cmd
  IO () -> m ()
forall a. IO a -> m a
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 :: 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 ()
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.
(HasCallStack, 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
      (\CreateProcess
x -> CreateProcess
x { std_out = CreatePipe , std_err = CreatePipe }) ProcessSpec
process
    )
    (IO () -> m ()
forall a. IO a -> m a
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
      (Maybe Handle
_, Just Handle
out, Just Handle
err, ProcessHandle
p) -> do
        Handle -> Handle -> m ()
f Handle
out Handle
err
        (Handle
out, Handle
err) (Handle, Handle) -> m () -> m (Handle, Handle)
forall a b. a -> m b -> m a
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)
      (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ -> String -> m (Handle, Handle)
forall a. HasCallStack => String -> a
error String
"withProcess: createProcess did not provide handles for CreatePipe as expected"
    )

-- | Runs a process to completion, aborting the computation (using
-- 'throwExitCode') in case of a non-'ExitSuccess' exit status.
runProcess_
  :: (MonadIO m, CliLog m, CliThrow e m, MonadMask m, AsProcessFailure e)
  => ProcessSpec -> m ()
runProcess_ :: forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, MonadMask m,
 AsProcessFailure e) =>
ProcessSpec -> m ()
runProcess_ 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.
(HasCallStack, 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 a. IO a -> m a
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)
    (\(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, 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)

-- Create an input stream from the file handle, associating each item with the given severity.
streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))
streamHandle :: Severity -> Handle -> IO (InputStream (Severity, ByteString))
streamHandle 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

-- | Read from an input stream and log its contents
streamToLog
  :: (MonadIO m, CliLog m)
  => InputStream (Severity, BSC.ByteString) -> m ()
streamToLog :: forall (m :: * -> *).
(MonadIO m, CliLog m) =>
InputStream (Severity, ByteString) -> m ()
streamToLog 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
$ \m ()
loop -> do
  IO (Maybe (Severity, ByteString))
-> m (Maybe (Severity, ByteString))
forall a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Severity, ByteString)
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (Severity
sev, 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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
loop

-- | Wrapper around `System.Process.waitForProcess`
waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode
waitForProcess :: forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess = IO ExitCode -> m ExitCode
forall a. IO a -> m a
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

-- | Aborts the computation (using 'throwError') when given a
-- non-'ExitSuccess' 'ExitCode'.
throwExitCode :: (CliThrow e m, AsProcessFailure e) => ProcessSpec -> ExitCode -> m ()
throwExitCode :: forall e (m :: * -> *).
(CliThrow e m, AsProcessFailure e) =>
ProcessSpec -> ExitCode -> m ()
throwExitCode ProcessSpec
spec = \case
  ExitCode
ExitSuccess -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ExitFailure Int
code -> e -> m ()
forall a. e -> m a
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
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

-- | Pretty print a 'CmdSpec'
reconstructCommand :: Process.CmdSpec -> Text
reconstructCommand :: CmdSpec -> Text
reconstructCommand CmdSpec
p = case CmdSpec
p of
  Process.ShellCommand String
str -> String -> Text
T.pack String
str
  Process.RawCommand String
c [String]
as -> String -> [String] -> Text
processToShellString String
c [String]
as
  where
    processToShellString :: String -> [String] -> Text
processToShellString String
cmd [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

-- | A wrapper for 'callProcessAndLogOutput' with sensible default
-- verbosities: standard output gets the 'Notice' severity and standard
-- error gets 'Error'.
runProc
  :: ( MonadIO m
     , CliLog m
     , CliThrow e m
     , AsProcessFailure e
     , MonadFail m
     , MonadMask m
     )
  => ProcessSpec -> m ()
runProc :: forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
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)

-- | Like 'runProc', but the child process' output and error streams get
-- the 'Debug' severity.
runProcSilently
  :: ( MonadIO m
     , CliLog m
     , CliThrow e m
     , AsProcessFailure e
     , MonadFail m
     , MonadMask m
     )
  => ProcessSpec -> m ()
runProcSilently :: forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m, MonadMask m) =>
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)

-- | A wrapper for 'readProcessAndLogOutput' with sensible default
-- verbosities: standard output gets the 'Debug' severity and standard
-- error gets 'Error'.
--
-- The child process' output gets the 'Debug' severity rather than the
-- 'Notice' severity because it is first and foremost /returned by this
-- function/, so you can log it afterwards in a reasonable manner.
readProc
  :: ( MonadIO m
     , CliLog m
     , CliThrow e m
     , AsProcessFailure e
     , MonadFail m
     )
  => ProcessSpec -> m Text
readProc :: forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m) =>
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)