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


-- 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
showList :: [ProcessFailure] -> ShowS
$cshowList :: [ProcessFailure] -> ShowS
show :: ProcessFailure -> String
$cshow :: ProcessFailure -> String
showsPrec :: Int -> ProcessFailure -> ShowS
$cshowsPrec :: Int -> 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 :: 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 ""

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

  -- TODO interleave stdout and stderr in log correctly
  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)

-- | 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 :: (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]

-- | 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 :: 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

-- | 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_ :: 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) }

-- | Like 'System.Process.callProcess', but logging (with 'Debug'
-- severity) the process which was started.
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

-- | Like 'System.Process.callCommand', but logging (with 'Debug'
-- severity) the process which was started.
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"
    )

-- | 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_ :: 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)

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

-- | Read from an input stream and log its contents
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

-- | Wrapper around `System.Process.waitForProcess`
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

-- | Aborts the computation (using 'throwError') when given a
-- non-'ExitSuccess' 'ExitCode'.
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

-- | Pretty print a 'CmdSpec'
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

-- | 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 :: 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 :: 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 :: 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)