@@ -9,17 +9,24 @@
99-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)
1010-- and is thus spinner friendly.
1111module Obelisk.CliApp.Process
12− ( ProcessFailure (..)
13− , AsProcessFailure (..)
14− , readProcessAndLogStderr
15− , readProcessAndLogOutput
16− , readCreateProcessWithExitCode
12+ ( AsProcessFailure (..)
13+ , ProcessFailure (..)
14+ , ProcessSpec (..)
15+ , callCommand
16+ , callProcess
1717 , callProcessAndLogOutput
1818 , createProcess
1919 , createProcess_
20− , callProcess
21− , callCommand
20+ , overCreateProcess
21+ , proc
22+ , readCreateProcessWithExitCode
23+ , readProcessAndLogOutput
24+ , readProcessAndLogStderr
2225 , reconstructCommand
26+ , setCwd
27+ , setDelegateCtlc
28+ , setEnvOverride
29+ , shell
2330 ) where
2431
2532import Control.Monad ((<=<), join, void)
@@ -30,24 +37,50 @@ import Control.Lens (Prism', review)
3037import qualified Data.ByteString as BS
3138import qualified Data.ByteString.Char8 as BSC
3239import Data.Function (fix)
40+import Data.Map (Map)
41+import qualified Data.Map as Map
3342import Data.Monoid ((<>))
3443import Data.Text (Text)
3544import qualified Data.Text as T
3645import qualified Data.Text.Encoding as T
3746import Data.Text.Encoding.Error (lenientDecode)
47+import System.Environment (getEnvironment)
3848import System.Exit (ExitCode (..))
3949import System.IO (Handle)
4050import System.IO.Streams (InputStream, handleToInputStream)
4151import qualified System.IO.Streams as Streams
4252import System.IO.Streams.Concurrent (concurrentMerge)
43−import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), cmdspec, std_err, std_out,
44− waitForProcess)
53+import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), std_err, std_out, waitForProcess)
4554import qualified System.Process as Process
4655
4756import Control.Monad.Log (Severity (..))
4857import Obelisk.CliApp.Logging (putLog, putLogRaw)
4958import Obelisk.CliApp.Types (CliLog, CliThrow)
5059
60+data ProcessSpec = ProcessSpec
61+ { _processSpec_createProcess :: !CreateProcess
62+ , _processSpec_overrideEnv :: !(Maybe (Map String String -> Map String String))
63+ }
64+
65+proc :: FilePath -> [String] -> ProcessSpec
66+proc cmd args = ProcessSpec (Process.proc cmd args) Nothing
67+
68+shell :: String -> ProcessSpec
69+shell cmd = ProcessSpec (Process.shell cmd) Nothing
70+
71+setEnvOverride :: (Map String String -> Map String String) -> ProcessSpec -> ProcessSpec
72+setEnvOverride f p = p { _processSpec_overrideEnv = Just f }
73+
74+overCreateProcess :: (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec
75+overCreateProcess f (ProcessSpec p x) = ProcessSpec (f p) x
76+
77+setDelegateCtlc :: Bool -> ProcessSpec -> ProcessSpec
78+setDelegateCtlc b = overCreateProcess (\p -> p { Process.delegate_ctlc = b })
79+
80+setCwd :: Maybe FilePath -> ProcessSpec -> ProcessSpec
81+setCwd fp = overCreateProcess (\p -> p { Process.cwd = fp })
82+
83+
5184-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions
5285data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code
5386 deriving Show
@@ -62,7 +95,7 @@ instance AsProcessFailure ProcessFailure where
6295
6396readProcessAndLogStderr
6497 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
65− => Severity -> CreateProcess -> m Text
98+ => Severity -> ProcessSpec -> m Text
6699readProcessAndLogStderr sev process = do
67100 (out, _err) <- withProcess process $ \_out err -> do
68101 streamToLog =<< liftIO (streamHandle sev err)
@@ -70,9 +103,10 @@ readProcessAndLogStderr sev process = do
70103
71104readCreateProcessWithExitCode
72105 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
73− => CreateProcess -> m (ExitCode, String, String)
74−readCreateProcessWithExitCode process = do
75− putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec process)
106+ => ProcessSpec -> m (ExitCode, String, String)
107+readCreateProcessWithExitCode procSpec = do
108+ process <- mkCreateProcess procSpec
109+ putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec
76110 liftIO $ Process.readCreateProcessWithExitCode process ""
77111
78112-- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)
@@ -84,10 +118,10 @@ readCreateProcessWithExitCode process = do
84118-- `callProcessAndLogOutput (Debug, Debug)`.
85119readProcessAndLogOutput
86120 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
87− => (Severity, Severity) -> CreateProcess -> m Text
121+ => (Severity, Severity) -> ProcessSpec -> m Text
88122readProcessAndLogOutput (sev_out, sev_err) process = do
89− (_, Just out, Just err, p) <- createProcess $ process
90− { std_out = CreatePipe , std_err = CreatePipe }
123+ (_, Just out, Just err, p) <- createProcess $ overCreateProcess
124+ (\p -> p { std_out = CreatePipe , std_err = CreatePipe }) process
91125
92126 -- TODO interleave stdout and stderr in log correctly
93127 streamToLog =<< liftIO (streamHandle sev_err err)
@@ -96,9 +130,9 @@ readProcessAndLogOutput (sev_out, sev_err) process = do
96130
97131 liftIO (waitForProcess p) >>= \case
98132 ExitSuccess -> pure outText
99− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code
133+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code
100134
101−-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)
135+-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)
102136-- with the corresponding severity.
103137--
104138-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
@@ -106,9 +140,8 @@ readProcessAndLogOutput (sev_out, sev_err) process = do
106140-- which case it is advisable to call it with a non-Error severity for stderr, like
107141-- `callProcessAndLogOutput (Debug, Debug)`.
108142callProcessAndLogOutput
109−
110143 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
111− => (Severity, Severity) -> CreateProcess -> m ()
144+ => (Severity, Severity) -> ProcessSpec -> m ()
112145callProcessAndLogOutput (sev_out, sev_err) process =
113146 void $ withProcess process $ \out err -> do
114147 stream <- liftIO $ join $ combineStream
@@ -118,21 +151,31 @@ callProcessAndLogOutput (sev_out, sev_err) process =
118151 where
119152 combineStream s1 s2 = concurrentMerge [s1, s2]
120153
121−-- | Like `System.Process.createProcess` but also logs (debug) the process being run
154+-- | Like 'System.Process.createProcess' but also logs (debug) the process being run
122155createProcess
123156 :: (MonadIO m, CliLog m)
124− => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
125−createProcess p = do
126− putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec p)
157+ => ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
158+createProcess procSpec = do
159+ p <- mkCreateProcess procSpec
160+ putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec
127161 liftIO $ Process.createProcess p
128162
129163-- | Like `System.Process.createProcess_` but also logs (debug) the process being run
130164createProcess_
131165 :: (MonadIO m, CliLog m)
132− => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
133−createProcess_ name p = do
134− putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructCommand (cmdspec p)
135− liftIO $ Process.createProcess p
166+ => String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
167+createProcess_ name procSpec = do
168+ p <- mkCreateProcess procSpec
169+ putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructProcSpec procSpec
170+ liftIO $ Process.createProcess_ name p
171+
172+mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess
173+mkCreateProcess (ProcessSpec p override') = do
174+ case override' of
175+ Nothing -> pure p
176+ Just override -> do
177+ procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)
178+ pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }
136179
137180-- | Like `System.Process.callProcess` but also logs (debug) the process being run
138181callProcess
@@ -152,17 +195,17 @@ callCommand cmd = do
152195
153196withProcess
154197 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
155− => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
198+ => ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
156199withProcess process f = do -- TODO: Use bracket.
157200 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.
158− (_, Just out, Just err, p) <- createProcess $ process
159− { std_out = CreatePipe , std_err = CreatePipe }
201+ (_, Just out, Just err, p) <- createProcess $ overCreateProcess
202+ (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process
160203
161204 f out err -- Pass the handles to the passed function
162205
163206 liftIO (waitForProcess p) >>= \case
164207 ExitSuccess -> return (out, err)
165− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code
208+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code
166209
167210-- Create an input stream from the file handle, associating each item with the given severity.
168211streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))
@@ -179,8 +222,12 @@ streamToLog stream = fix $ \loop -> do
179222
180223-- | Pretty print a 'CmdSpec'
181224reconstructCommand :: Process.CmdSpec -> Text
182−reconstructCommand (Process.ShellCommand str) = T.pack str
183−reconstructCommand (Process.RawCommand c as) = processToShellString c as
225+reconstructCommand p = case p of
226+ Process.ShellCommand str -> T.pack str
227+ Process.RawCommand c as -> processToShellString c as
184228 where
185229 processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)
186230 quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"
231+
232+reconstructProcSpec :: ProcessSpec -> Text
233+reconstructProcSpec = reconstructCommand . Process.cmdspec . _processSpec_createProcess