Wait for child process to exit in the daml assistant and daml-helper (d…

…igital-asset#2162) fixes digital-asset#2142 It turns out that typed-process has the behavior we want so rather than rolling our own version of `withCreateProcess`, I just switched to that.
iggy-da · Jul 16, 2019 · 623e641 · 623e641
1 parent 3a93647
commit 623e641
Show file tree

Hide file tree

Showing 5 changed files with 26 additions and 28 deletions.
diff --git a/WORKSPACE b/WORKSPACE
@@ -570,7 +570,8 @@ hazel_repositories(
                 "c593ff871f31200e37a3c24c09da314d0ee41a8486defe7af91ac55a26efdc1e",
                 patch_args = ["-p1"],
                 patches = ["@com_github_digital_asset_daml//bazel_tools:haskell-hie-bios.patch"],
-            ),
+            ) +
+            hazel_hackage("typed-process", "0.2.6.0", "31a2a81f33463fedc33cc519ad5b9679787e648fe2ec7efcdebd7d54bdbbc2b1"),
         pkgs = packages,
     ),
 )

diff --git a/daml-assistant/BUILD.bazel b/daml-assistant/BUILD.bazel
@@ -83,9 +83,9 @@ da_haskell_binary(
         "directory",
         "extra",
         "filepath",
-        "process",
         "safe",
         "safe-exceptions",
+        "typed-process",
         "text",
     ],
     main_function = "DAML.Assistant.main",

diff --git a/daml-assistant/daml-helper/BUILD.bazel b/daml-assistant/daml-helper/BUILD.bazel
@@ -24,9 +24,10 @@ da_haskell_library(
         "network",
         "open-browser",
         "optparse-applicative",
-        "process",
         "safe-exceptions",
         "text",
+        "typed-process",
+        "utf8-string",
         "yaml",
     ],
     visibility = ["//visibility:public"],

diff --git a/daml-assistant/daml-helper/src/DamlHelper/Run.hs b/daml-assistant/daml-helper/src/DamlHelper/Run.hs
@@ -37,6 +37,7 @@ import Control.Monad.Loops (untilJust)
 import Data.Maybe
 import Data.List.Extra
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy.UTF8 as UTF8
 import qualified Data.Text as T
 import qualified Data.Yaml as Y
 import qualified Data.Yaml.Pretty as Y
@@ -46,10 +47,10 @@ import Network.Socket
 import System.FilePath
 import qualified System.Directory as Dir
 import System.Directory.Extra
-import System.Environment
+import System.Environment hiding (setEnv)
 import System.Exit
 import System.Info.Extra
-import System.Process hiding (runCommand)
+import System.Process.Typed
 import System.IO
 import System.IO.Extra
 import Web.Browser
@@ -95,8 +96,9 @@ runVsCodeCommand args = do
         commandEnv = addVsCodeToPath strippedEnv
             -- ^ Ensure "code" is in PATH before running command.
         command = unwords ("code" : args)
-        process = (shell command) { env = Just commandEnv }
-    readCreateProcessWithExitCode process ""
+        process = setEnv commandEnv (shell command)
+    (exit, out, err) <- readProcess process
+    pure (exit, UTF8.toString out, UTF8.toString err)
 
 -- | Add VSCode bin path to environment PATH. Only need to add it on Mac, as
 -- VSCode is installed in PATH by default on the other platforms.
@@ -237,15 +239,13 @@ installBundledExtension pathToVsix = do
            ]
 
 runJar :: FilePath -> [String] -> IO ()
-runJar jarPath remainingArguments = do
-    exitCode <- withJar jarPath remainingArguments waitForProcess
-    exitWith exitCode
+runJar jarPath remainingArguments = withJar jarPath remainingArguments (const $ pure ())
 
-withJar :: FilePath -> [String] -> (ProcessHandle -> IO a) -> IO a
+withJar :: FilePath -> [String] -> (Process () () () -> IO a) -> IO a
 withJar jarPath args a = do
     sdkPath <- getSdkPath
     let absJarPath = sdkPath </> jarPath
-    (withCreateProcess (proc "java" ("-jar" : absJarPath : args)) $ \_ _ _ -> a) `catchIO`
+    withProcessWait_ (proc "java" ("-jar" : absJarPath : args)) a `catchIO`
         (\e -> hPutStrLn stderr "Failed to start java. Make sure it is installed and in the PATH." *> throwIO e)
 
 getTemplatesFolder :: IO FilePath
@@ -547,8 +547,8 @@ runMigrate targetFolder pkgPath1 pkgPath2
 
     -- Call damlc to create the upgrade source files.
     assistant <- getDamlAssistant
-    callCommand
-        (unwords $
+    runProcess_
+        (shell $ unwords $
          assistant :
          [ "damlc"
          , "migrate"
@@ -613,15 +613,15 @@ navigatorPortNavigatorArgs (NavigatorPort p) = ["--port", show p]
 navigatorURL :: NavigatorPort -> String
 navigatorURL (NavigatorPort p) = "http://localhost:" <> show p
 
-withSandbox :: SandboxPort -> [String] -> (ProcessHandle -> IO a) -> IO a
+withSandbox :: SandboxPort -> [String] -> (Process () () () -> IO a) -> IO a
 withSandbox (SandboxPort port) args a = do
     withJar sandboxPath (["--port", show port] ++ args) $ \ph -> do
         putStrLn "Waiting for sandbox to start: "
         -- TODO We need to figure out what a sane timeout for this step.
         waitForConnectionOnPort (putStr "." *> threadDelay 500000) port
         a ph
 
-withNavigator :: SandboxPort -> NavigatorPort -> [String] -> (ProcessHandle-> IO a) -> IO a
+withNavigator :: SandboxPort -> NavigatorPort -> [String] -> (Process () () () -> IO a) -> IO a
 withNavigator (SandboxPort sandboxPort) navigatorPort args a = do
     let navigatorArgs = concat
             [ ["server", "localhost", show sandboxPort]
@@ -654,18 +654,15 @@ runStart (StartNavigator shouldStartNavigator) (OpenBrowser shouldOpenBrowser) o
         queryProjectConfig ["scenario"] projectConfig
     let darPath = ".daml" </> "dist" </> projectName <> ".dar"
     assistant <- getDamlAssistant
-    callCommand (unwords $ assistant : ["build"])
+    runProcess_ (shell $ unwords $ assistant : ["build"])
     let scenarioArgs = maybe [] (\scenario -> ["--scenario", scenario]) mbScenario
     withSandbox sandboxPort (darPath : scenarioArgs) $ \sandboxPh -> do
         withNavigator' sandboxPh sandboxPort navigatorPort [] $ \navigatorPh -> do
-            whenJust onStartM $ \onStart -> do
-                exitCode <- withCreateProcess (shell onStart) $ \ _ _ _ -> waitForProcess
-                when (exitCode /= ExitSuccess) $
-                    exitWith exitCode
+            whenJust onStartM $ \onStart -> runProcess_ (shell onStart)
             when (shouldStartNavigator && shouldOpenBrowser) $
                 void $ openBrowser (navigatorURL navigatorPort)
             when shouldWaitForSignal $
-                void $ race (waitForProcess navigatorPh) (waitForProcess sandboxPh)
+                void $ race (waitExitCode navigatorPh) (waitExitCode sandboxPh)
 
     where sandboxPort = SandboxPort 6865
           navigatorPort = NavigatorPort 7500

diff --git a/daml-assistant/exe/DAML/Assistant.hs b/daml-assistant/exe/DAML/Assistant.hs
@@ -17,7 +17,7 @@ import DAML.Assistant.Install
 import DAML.Assistant.Util
 import System.FilePath
 import System.Directory
-import System.Process
+import System.Process.Typed
 import System.Exit
 import System.IO
 import Control.Exception.Safe
@@ -208,21 +208,20 @@ handleCommand env@Env{..} = \case
     Builtin (Exec cmd args) -> do
         wrapErr "Running executable in daml environment." $ do
             path <- fromMaybe cmd <$> findExecutable cmd
-            exitWith =<< dispatch env path args
+            dispatch env path args
 
     Dispatch SdkCommandInfo{..} cmdArgs -> do
         wrapErr ("Running " <> unwrapSdkCommandName sdkCommandName <> " command.") $ do
             sdkPath <- required "Could not determine SDK path." envSdkPath
             let path = unwrapSdkPath sdkPath </> unwrapSdkCommandPath sdkCommandPath
                 args = unwrapSdkCommandArgs sdkCommandArgs ++ unwrapUserCommandArgs cmdArgs
-            exitWith =<< dispatch env path args
+            dispatch env path args
 
-dispatch :: Env -> FilePath -> [String] -> IO ExitCode
+dispatch :: Env -> FilePath -> [String] -> IO ()
 dispatch env path args = do
     dispatchEnv <- getDispatchEnv env
     requiredIO "Failed to spawn command subprocess." $
-        withCreateProcess (proc path args) { env = Just dispatchEnv }
-            (\ _ _ _ -> waitForProcess)
+        runProcess_ (setEnv dispatchEnv $ proc path args)
 
 displayErrors :: IO () -> IO ()
 displayErrors m = m `catches`