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

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


-- TODO put back in `Cli.Extras.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

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

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

-- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)
-- with the corresponding severity.
--
-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
-- some processes are known to spit out diagnostic or informative messages in stderr, in
-- which case it is advisable to call it with a non-Error severity for stderr, like
-- `callProcessAndLogOutput (Debug, Debug)`.
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

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

  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

-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)
-- with the corresponding severity.
--
-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
-- some processes are known to spit out diagnostic or informative messages in stderr, in
-- which case it is advisable to call it with a non-Error severity for stderr, like
-- `callProcessAndLogOutput (Debug, Debug)`.
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]

-- | Like 'System.Process.createProcess' but also logs (debug) the process being run
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 also logs (debug) the process being run
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) }

-- | Like `System.Process.callProcess` but also logs (debug) the process being run
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 also logs (debug) the command being run
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 -- TODO: Use bracket.
  -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.
  (_, 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  -- Pass the handles to the passed function

  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

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

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