bfa6308 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

cliapp, command: Preserve exit code for subprocesses

bfa6308Elliot Cameron6 years ago

lib/cliapp/src/Obelisk/CliApp.hs+2

compare with master

unifiedsplit

@@ -41,6 +41,7 @@ module Obelisk.CliApp

41 , callProcessAndLogOutput

42 , createProcess

43 , createProcess_

44+ , exitCodeToException

44 , overCreateProcess

45 , overCreateProcess

45 , proc

46 , proc

46 , readCreateProcessWithExitCode

47 , readCreateProcessWithExitCode

@@ -48,6 +49,7 @@ module Obelisk.CliApp

48 , readProcessAndLogStderr

49 , readProcessAndLogStderr

49 , readProcessJSONAndLogStderr

50 , readProcessJSONAndLogStderr

50 , reconstructCommand

51 , reconstructCommand

52+ , runProcess_

51 , setCwd

53 , setCwd

52 , setDelegateCtlc

54 , setDelegateCtlc

53 , setEnvOverride

55 , setEnvOverride

lib/cliapp/src/Obelisk/CliApp/Process.hs+39−23

@@ -17,6 +17,7 @@ module Obelisk.CliApp.Process

17 , callProcessAndLogOutput

18 , createProcess

19 , createProcess_

20+ , exitCodeToException

20 , overCreateProcess

21 , overCreateProcess

21 , proc

22 , proc

22 , readCreateProcessWithExitCode

23 , readCreateProcessWithExitCode

@@ -24,6 +25,7 @@ module Obelisk.CliApp.Process

24 , readProcessAndLogStderr

25 , readProcessAndLogStderr

25 , readProcessJSONAndLogStderr

26 , readProcessJSONAndLogStderr

26 , reconstructCommand

27 , reconstructCommand

28+ , runProcess_

27 , setCwd

29 , setCwd

28 , setDelegateCtlc

30 , setDelegateCtlc

29 , setEnvOverride

31 , setEnvOverride

@@ -32,6 +34,7 @@ module Obelisk.CliApp.Process

32 ) where

34 ) where

34import Control.Monad ((<=<), join, void)

36import Control.Monad ((<=<), join, void)

37+import Control.Monad.Catch (MonadMask, bracketOnError)

35import Control.Monad.Except (throwError)

38import Control.Monad.Except (throwError)

36import Control.Monad.Fail

39import Control.Monad.Fail

37import Control.Monad.IO.Class (MonadIO, liftIO)

40import Control.Monad.IO.Class (MonadIO, liftIO)

@@ -99,7 +102,7 @@ instance AsProcessFailure ProcessFailure where

99 asProcessFailure = id

102 asProcessFailure = id

100

103

101readProcessAndLogStderr

104readProcessAndLogStderr

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)

103 => Severity -> ProcessSpec -> m Text

106 => Severity -> ProcessSpec -> m Text

104readProcessAndLogStderr sev process = do

107readProcessAndLogStderr sev process = do

105 (out, _err) <- withProcess process $ \_out err -> do

108 (out, _err) <- withProcess process $ \_out err -> do

@@ -107,7 +110,7 @@ readProcessAndLogStderr sev process = do

107 liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out

110 liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out

108

111

109readProcessJSONAndLogStderr

112readProcessJSONAndLogStderr

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)

111 => Severity -> ProcessSpec -> m a

114 => Severity -> ProcessSpec -> m a

112readProcessJSONAndLogStderr sev process = do

115readProcessJSONAndLogStderr sev process = do

113 (out, _err) <- withProcess process $ \_out err -> do

116 (out, _err) <- withProcess process $ \_out err -> do

@@ -146,9 +149,7 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

146 outText <- liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out

149 outText <- liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out

147 putLogRaw sev_out outText

150 putLogRaw sev_out outText

148

151

149− waitForProcess p >>= \case

152+ outText <$ (exitCodeToException process =<< waitForProcess p)

150− ExitSuccess -> pure outText

151− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code

152

153

153-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)

154-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)

154-- with the corresponding severity.

155-- with the corresponding severity.

@@ -158,7 +159,7 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

158-- which case it is advisable to call it with a non-Error severity for stderr, like

159-- which case it is advisable to call it with a non-Error severity for stderr, like

159-- `callProcessAndLogOutput (Debug, Debug)`.

160-- `callProcessAndLogOutput (Debug, Debug)`.

160callProcessAndLogOutput

161callProcessAndLogOutput

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)

162 => (Severity, Severity) -> ProcessSpec -> m ()

163 => (Severity, Severity) -> ProcessSpec -> m ()

163callProcessAndLogOutput (sev_out, sev_err) process =

164callProcessAndLogOutput (sev_out, sev_err) process =

164 void $ withProcess process $ \out err -> do

165 void $ withProcess process $ \out err -> do

@@ -188,12 +189,11 @@ createProcess_ name procSpec = do

188 liftIO $ Process.createProcess_ name p

189 liftIO $ Process.createProcess_ name p

189

190

190mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess

191mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess

191−mkCreateProcess (ProcessSpec p override') = do

192+mkCreateProcess (ProcessSpec p override') = case override' of

192− case override' of

193− Nothing -> pure p

193+ Nothing -> pure p

194− Just override -> do

194+ Just override -> do

195− procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)

195+ procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)

196− pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }

196+ pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }

197

198-- | Like `System.Process.callProcess` but also logs (debug) the process being run

199callProcess

@@ -212,18 +212,28 @@ callCommand cmd = do

212 liftIO $ Process.callCommand cmd

213

214withProcess

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)

216 => ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

217−withProcess process f = do -- TODO: Use bracket.

217+withProcess process f =

218− -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

218+ bracketOnError

219− (_, Just out, Just err, p) <- createProcess $ overCreateProcess

219+ (createProcess $ overCreateProcess

220− (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process

220+ (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process

221−

221+ )

222+ (liftIO . Process.cleanupProcess)

223+ (\(_, Just out, Just err, p) -> do

222− f out err -- Pass the handles to the passed function

224+ f out err -- Pass the handles to the passed function

223−

224− waitForProcess p >>= \case

225+ (out, err) <$ (exitCodeToException process =<< waitForProcess p)

225− ExitSuccess -> return (out, err)

226+ )

226− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code

227+

228+-- | Runs a process to completion failing if it does not exit cleanly.

229+runProcess_

230+ :: (MonadIO m, CliLog m, CliThrow e m, MonadMask m, AsProcessFailure e, MonadFail m)

231+ => ProcessSpec -> m ()

232+runProcess_ process =

233+ bracketOnError -- TODO: Wrap exceptions up in ProcessFailure

234+ (createProcess process)

235+ (liftIO . Process.cleanupProcess)

236+ (\(_, _, _, ph) -> exitCodeToException process =<< waitForProcess ph)

227

237

228-- Create an input stream from the file handle, associating each item with the given severity.

238-- Create an input stream from the file handle, associating each item with the given severity.

229streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))

239streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))

@@ -242,6 +252,12 @@ streamToLog stream = fix $ \loop -> do

242waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode

252waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode

243waitForProcess = liftIO . Process.waitForProcess

253waitForProcess = liftIO . Process.waitForProcess

244

254

255+-- | Converts an 'ExitCode' to an exception when it's non-zero.

256+exitCodeToException :: (CliThrow e m, AsProcessFailure e) => ProcessSpec -> ExitCode -> m ()

257+exitCodeToException spec = \case

258+ ExitSuccess -> pure ()

259+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess spec) code

260+

245-- | Pretty print a 'CmdSpec'

261-- | Pretty print a 'CmdSpec'

246reconstructCommand :: Process.CmdSpec -> Text

262reconstructCommand :: Process.CmdSpec -> Text

247reconstructCommand p = case p of

263reconstructCommand p = case p of

lib/command/src/Obelisk/Command/Project.hs+2−4

@@ -307,7 +307,7 @@ nixShellWithoutPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr comma

307 packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute

308 defShellConfig <- nixShellRunConfig root isPure command

309 let setCwd_ = if chdirToRoot then setCwd (Just root) else id

310− (_, _, _, ph) <- createProcess_ "nixShellWithoutPkgs" $ setCwd_ $ nixShellRunProc $ defShellConfig

310+ runProcess_ $ setCwd_ $ nixShellRunProc $ defShellConfig

311 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~

312 "{root, pkgs, shell}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\

313 \shellPackages = builtins.fromJSON pkgs;\

@@ -317,18 +317,16 @@ nixShellWithoutPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr comma

317 , strArg "pkgs" (T.unpack $ decodeUtf8 $ BSL.toStrict $ Json.encode packageNamesAndAbsPaths)

318 , strArg "shell" shellAttr

319 ]

320− void $ waitForProcess ph

321

320

322nixShellWithHoogle :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

321nixShellWithHoogle :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

323nixShellWithHoogle root isPure shell' command = do

322nixShellWithHoogle root isPure shell' command = do

324 defShellConfig <- nixShellRunConfig root isPure command

323 defShellConfig <- nixShellRunConfig root isPure command

325− (_, _, _, ph) <- createProcess_ "nixShellWithHoogle" $ setCwd (Just root) $ nixShellRunProc $ defShellConfig

324+ runProcess_ $ setCwd (Just root) $ nixShellRunProc $ defShellConfig

326 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~

325 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~

327 "{shell}: ((import ./. {}).passthru.__unstable__.self.extend (_: super: {\

326 "{shell}: ((import ./. {}).passthru.__unstable__.self.extend (_: super: {\

328 \userSettings = super.userSettings // { withHoogle = true; };\

327 \userSettings = super.userSettings // { withHoogle = true; };\

329 \})).project.shells.${shell}"

328 \})).project.shells.${shell}"

330 & nixShellConfig_common . nixCmdConfig_args .~ [ strArg "shell" shell' ]

329 & nixShellConfig_common . nixCmdConfig_args .~ [ strArg "shell" shell' ]

331− void $ waitForProcess ph

332

330

333findProjectAssets :: MonadObelisk m => FilePath -> m Text

331findProjectAssets :: MonadObelisk m => FilePath -> m Text

334findProjectAssets root = do

332findProjectAssets root = do

lib/command/src/Obelisk/Command/Run.hs+3−5

@@ -14,7 +14,7 @@ module Obelisk.Command.Run where

14import Control.Arrow ((&&&))

15import Control.Exception (Exception, bracket)

16import Control.Lens (ifor, (.~), (&))

17−import Control.Monad (filterM, unless, void)

17+import Control.Monad (filterM, unless)

18import Control.Monad.Except (runExceptT, throwError)

19import Control.Monad.IO.Class (liftIO)

20import Control.Monad.Reader (MonadIO)

@@ -66,15 +66,14 @@ import System.IO.Temp (withSystemTempDirectory)

66import Obelisk.App (MonadObelisk)

67import Obelisk.CliApp (

68 Severity (..),

69− createProcess_,

70 failWith,

69 failWith,

71 proc,

70 proc,

72 putLog,

71 putLog,

73 readCreateProcessWithExitCode,

72 readCreateProcessWithExitCode,

74 readProcessAndLogStderr,

73 readProcessAndLogStderr,

74+ runProcess_,

75 setCwd,

76 setDelegateCtlc,

77− waitForProcess,

78 withSpinner,

77 withSpinner,

79 )

78 )

80import Obelisk.Command.Nix

79import Obelisk.Command.Nix

@@ -150,7 +149,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do

150 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName

149 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName

151 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)

150 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)

152 freePort <- getFreePort

151 freePort <- getFreePort

153− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $

152+ runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $

154 [ show freePort

153 [ show freePort

155 , T.unpack assets

154 , T.unpack assets

156 , profileBaseName

155 , profileBaseName

@@ -158,7 +157,6 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do

158 , "-po" <> profileBaseName

157 , "-po" <> profileBaseName

159 ] <> rtsFlags

158 ] <> rtsFlags

160 <> [ "-RTS" ]

159 <> [ "-RTS" ]

161− void $ waitForProcess ph

162

160

163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

161run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

164run root interpretPaths = do

162run root interpretPaths = do