@@ -17,6 +17,7 @@ module Obelisk.CliApp.Process
1717 , callProcessAndLogOutput
1818 , createProcess
1919 , createProcess_
20+ , exitCodeToException
2021 , overCreateProcess
2122 , proc
2223 , readCreateProcessWithExitCode
@@ -24,6 +25,7 @@ module Obelisk.CliApp.Process
2425 , readProcessAndLogStderr
2526 , readProcessJSONAndLogStderr
2627 , reconstructCommand
28+ , runProcess_
2729 , setCwd
2830 , setDelegateCtlc
2931 , setEnvOverride
@@ -32,6 +34,7 @@ module Obelisk.CliApp.Process
3234 ) where
3335
3436import Control.Monad ((<=<), join, void)
37+import Control.Monad.Catch (MonadMask, bracketOnError)
3538import Control.Monad.Except (throwError)
3639import Control.Monad.Fail
3740import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -99,7 +102,7 @@ instance AsProcessFailure ProcessFailure where
99102 asProcessFailure = id
100103
101104readProcessAndLogStderr
102− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
105+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m, MonadMask m)
103106 => Severity -> ProcessSpec -> m Text
104107readProcessAndLogStderr sev process = do
105108 (out, _err) <- withProcess process $ \_out err -> do
@@ -107,7 +110,7 @@ readProcessAndLogStderr sev process = do
107110 liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out
108111
109112readProcessJSONAndLogStderr
110− :: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
113+ :: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m, MonadMask m)
111114 => Severity -> ProcessSpec -> m a
112115readProcessJSONAndLogStderr sev process = do
113116 (out, _err) <- withProcess process $ \_out err -> do
@@ -146,9 +149,7 @@ readProcessAndLogOutput (sev_out, sev_err) process = do
146149 outText <- liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out
147150 putLogRaw sev_out outText
148151
149− waitForProcess p >>= \case
150− ExitSuccess -> pure outText
151− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code
152+ outText <$ (exitCodeToException process =<< waitForProcess p)
152153
153154-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)
154155-- with the corresponding severity.
@@ -158,7 +159,7 @@ readProcessAndLogOutput (sev_out, sev_err) process = do
158159-- which case it is advisable to call it with a non-Error severity for stderr, like
159160-- `callProcessAndLogOutput (Debug, Debug)`.
160161callProcessAndLogOutput
161− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
162+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m, MonadMask m)
162163 => (Severity, Severity) -> ProcessSpec -> m ()
163164callProcessAndLogOutput (sev_out, sev_err) process =
164165 void $ withProcess process $ \out err -> do
@@ -188,12 +189,11 @@ createProcess_ name procSpec = do
188189 liftIO $ Process.createProcess_ name p
189190
190191mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess
191−mkCreateProcess (ProcessSpec p override') = do
192− case override' of
193− Nothing -> pure p
194− Just override -> do
195− procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)
196− pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }
192+mkCreateProcess (ProcessSpec p override') = case override' of
193+ Nothing -> pure p
194+ Just override -> do
195+ procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)
196+ pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }
197197
198198-- | Like `System.Process.callProcess` but also logs (debug) the process being run
199199callProcess
@@ -212,18 +212,30 @@ callCommand cmd = do
212212 liftIO $ Process.callCommand cmd
213213
214214withProcess
215− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)
215+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m, MonadMask m)
216216 => ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
217−withProcess process f = do -- TODO: Use bracket.
218− -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.
219− (_, Just out, Just err, p) <- createProcess $ overCreateProcess
220− (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process
221−
222− f out err -- Pass the handles to the passed function
223−
224− waitForProcess p >>= \case
225− ExitSuccess -> return (out, err)
226− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code
217+withProcess process f =
218+ bracketOnError
219+ (createProcess $ overCreateProcess
220+ (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process
221+ )
222+ (liftIO . Process.cleanupProcess)
223+ (\case
224+ (_, Just out, Just err, p) -> do
225+ f out err
226+ (out, err) <$ (exitCodeToException process =<< waitForProcess p)
227+ _ -> error "withProcess: createProcess did not provide handles for CreatePipe as expected"
228+ )
229+
230+-- | Runs a process to completion failing if it does not exit cleanly.
231+runProcess_
232+ :: (MonadIO m, CliLog m, CliThrow e m, MonadMask m, AsProcessFailure e, MonadFail m)
233+ => ProcessSpec -> m ()
234+runProcess_ process =
235+ bracketOnError
236+ (createProcess process)
237+ (liftIO . Process.cleanupProcess)
238+ (\(_, _, _, ph) -> exitCodeToException process =<< waitForProcess ph)
227239
228240-- Create an input stream from the file handle, associating each item with the given severity.
229241streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))
@@ -242,6 +254,12 @@ streamToLog stream = fix $ \loop -> do
242254waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode
243255waitForProcess = liftIO . Process.waitForProcess
244256
257+-- | Converts an 'ExitCode' to an exception when it's non-zero.
258+exitCodeToException :: (CliThrow e m, AsProcessFailure e) => ProcessSpec -> ExitCode -> m ()
259+exitCodeToException spec = \case
260+ ExitSuccess -> pure ()
261+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess spec) code
262+
245263-- | Pretty print a 'CmdSpec'
246264reconstructCommand :: Process.CmdSpec -> Text
247265reconstructCommand p = case p of