Add eager timeouts to the polling functions used in daml start and assistant integration tests. (#12361)

* Add timeouts to polling funcs in daml start.

This PR adds timeouts to some polling functions used in daml start and
the assistant integration tests, and also early exits based on a process
exit status. E.g. waitForHttpServer will make sure some process is
still running, instead of waiting to timeout.

The effect of this is that now whenever there is some error in a
subprocess, daml start and the integration tests will finish early
instead of running forever (or timing out in bazel).

changelog_begin
changelog_end

* missing a readPortFile instance

bazel_tools/client_server/runner_with_port_file/Main.hs

@@ -28,7 +28,7 @@ main = do
     let portFile = tempDir </> "portfile"
     let interpolatedServerArgs = map (replace "%PORT_FILE%" portFile) splitServerArgs
     let serverProc = proc serverExe interpolatedServerArgs
-    withCreateProcess serverProc $ \_stdin _stdout _stderr _ph -> do
+    withCreateProcess serverProc $ \_stdin _stdout _stderr ph -> do
-      port <- readPortFile maxRetries portFile
+      port <- readPortFile ph maxRetries portFile
       let interpolatedClientArgs = map (replace "%PORT%" (show port)) splitClientArgs
       callProcess clientExe interpolatedClientArgs

compiler/repl-service/client/src/DA/Daml/LF/ReplClient.hs

@@ -113,7 +113,7 @@ withReplClient opts@Options{..} f = withTempFile $ \portFile -> do
         , concat [ ["--max-inbound-message-size", show (getMaxInboundMessageSize size)] | Just size <- [optMaxInboundMessageSize] ]
         ]
     withCreateProcess replServer { std_out = optStdout } $ \_ stdout _ ph -> do
-      port <- readPortFile maxRetries portFile
+      port <- readPortFile ph maxRetries portFile
       let grpcConfig = ClientConfig (Host "127.0.0.1") (Port port) [] Nothing Nothing
       threadDelay 1000000
       withGRPCClient grpcConfig $ \client -> do

daml-assistant/daml-helper/src/DA/Daml/Helper/Start.hs

@@ -127,7 +127,7 @@ withSandbox StartOptions{..} darPath scenarioArgs sandboxArgs kont =
       cantonOptions <- determineCantonOptions sandboxPortM cantonPortSpec portFile
       withCantonSandbox cantonOptions sandboxArgs $ \ph -> do
         putStrLn "Waiting for canton sandbox to start."
-        sandboxPort <- readPortFileWith decodeCantonSandboxPort maxRetries portFile
+        sandboxPort <- readPortFileWith decodeCantonSandboxPort (unsafeProcessHandle ph) maxRetries portFile
         runLedgerUploadDar ((defaultLedgerFlags Grpc) {fPortM = Just sandboxPort}) (Just darPath)
         kont ph (SandboxPort sandboxPort)
 
@@ -143,7 +143,7 @@ withSandbox StartOptions{..} darPath scenarioArgs sandboxArgs kont =
             ]
       withPlatformJar args "sandbox-logback.xml" $ \ph -> do
           putStrLn "Waiting for sandbox to start: "
-          port <- readPortFile maxRetries portFile
+          port <- readPortFile (unsafeProcessHandle ph) maxRetries portFile
           kont ph (SandboxPort port)
 
 withNavigator :: SandboxPort -> NavigatorPort -> [String] -> (Process () () () -> IO a) -> IO a
@@ -156,8 +156,8 @@ withNavigator (SandboxPort sandboxPort) navigatorPort args a = do
     logbackArg <- getLogbackArg (damlSdkJarFolder </> "navigator-logback.xml")
     withJar damlSdkJar [logbackArg] ("navigator":navigatorArgs) $ \ph -> do
         putStrLn "Waiting for navigator to start: "
-        -- TODO We need to figure out a sane timeout for this step.
+        waitForHttpServer 240 (unsafeProcessHandle ph) (putStr "." *> threadDelay 500000)
-        waitForHttpServer (putStr "." *> threadDelay 500000) (navigatorURL navigatorPort) []
+            (navigatorURL navigatorPort) []
         a ph
 
 withJsonApi :: SandboxPort -> JsonApiPort -> [String] -> (Process () () () -> IO a) -> IO a
@@ -185,7 +185,8 @@ withJsonApi (SandboxPort sandboxPort) (JsonApiPort jsonApiPort) extraArgs a = do
         let headers =
                 [ ("Authorization", "Bearer " <> T.encodeUtf8 token)
                 ] :: HTTP.RequestHeaders
-        waitForHttpServer (putStr "." *> threadDelay 500000) ("http://localhost:" <> show jsonApiPort <> "/v1/query") headers
+        waitForHttpServer 240 (unsafeProcessHandle ph) (putStr "." *> threadDelay 500000)
+            ("http://localhost:" <> show jsonApiPort <> "/v1/query") headers
         a ph
 
 data JsonApiConfig = JsonApiConfig

daml-assistant/daml-helper/src/DA/Daml/Helper/Util.hs

@@ -30,7 +30,6 @@ module DA.Daml.Helper.Util
 
 import Control.Exception.Safe
 import Control.Monad.Extra
-import Control.Monad.Loops (untilJust)
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.Lazy.Char8 as BSL8
@@ -45,7 +44,8 @@ import System.FilePath
 import System.IO
 import System.IO.Extra (withTempFile)
 import System.Info.Extra
-import System.Process (showCommandForUser, terminateProcess)
+import System.Exit (exitFailure)
+import System.Process (ProcessHandle, getProcessExitCode, showCommandForUser, terminateProcess)
 import System.Process.Typed
 import qualified Web.JWT as JWT
 import qualified Data.Aeson as A
@@ -196,35 +196,60 @@ damlSdkJarFolder = "daml-sdk"
 damlSdkJar :: FilePath
 damlSdkJar = damlSdkJarFolder </> "daml-sdk.jar"
 
--- | `waitForConnectionOnPort sleep port` keeps trying to establish a TCP connection on the given port.
+-- | `waitForConnectionOnPort numTries processHandle sleep port` tries to establish a TCP connection
--- Between each connection request it calls `sleep`.
+-- on the given port, in a given number of tries. Between each connection request it checks that a
-waitForConnectionOnPort :: IO () -> Int -> IO ()
+-- certain process is still alive and calls `sleep`.
-waitForConnectionOnPort sleep port = do
+waitForConnectionOnPort :: Int -> ProcessHandle -> IO () -> Int -> IO ()
+waitForConnectionOnPort 0 _processHandle _sleep port = do
+    hPutStrLn stderr ("Failed to connect to port " <> show port <> " in time.")
+    exitFailure
+waitForConnectionOnPort numTries processHandle sleep port = do
     let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream }
     addr : _ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port)
-    untilJust $ do
+    r <- tryIO $ checkConnection addr
-        r <- tryIO $ checkConnection addr
+    case r of
-        case r of
+        Right _ -> pure ()
-            Left _ -> sleep *> pure Nothing
+        Left _ -> do
-            Right _ -> pure $ Just ()
+            sleep
+            status <- getProcessExitCode processHandle
+            case status of
+                Nothing -> waitForConnectionOnPort (numTries-1) processHandle sleep port
+                Just exitCode -> do
+                    hPutStrLn stderr ("Failed to connect to port " <> show port
+                        <> " before process exited with " <> show exitCode)
+                    exitFailure
     where
         checkConnection addr = bracket
               (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
               close
               (\s -> connect s (addrAddress addr))
 
--- | `waitForHttpServer sleep url` keeps trying to establish an HTTP connection on the given URL.
+-- | `waitForHttpServer numTries processHandle sleep url headers` tries to establish an HTTP connection on
--- Between each connection request it calls `sleep`.
+-- the given URL with the given headers, in a given number of tries. Between each connection request
-waitForHttpServer :: IO () -> String -> HTTP.RequestHeaders -> IO ()
+-- it checks that a certain process is still alive and calls `sleep`.
-waitForHttpServer sleep url headers = do
+waitForHttpServer :: Int -> ProcessHandle -> IO () -> String -> HTTP.RequestHeaders -> IO ()
+waitForHttpServer 0 _processHandle _sleep url _headers = do
+    hPutStrLn stderr ("Failed to connect to HTTP server " <> url <> " in time.")
+    exitFailure
+waitForHttpServer numTries processHandle sleep url headers = do
     request <- HTTP.parseRequest $ "HEAD " <> url
     request <- pure (HTTP.setRequestHeaders headers request)
-    untilJust $ do
+    r <- tryJust (\e -> guard (isIOException e || isHttpException e)) $ HTTP.httpNoBody request
-        r <- tryJust (\e -> guard (isIOException e || isHttpException e)) $ HTTP.httpNoBody request
+    case r of
-        case r of
+        Right resp | HTTP.statusCode (HTTP.getResponseStatus resp) == 200 -> pure ()
-            Right resp
+        Right resp -> do
-                | HTTP.statusCode (HTTP.getResponseStatus resp) == 200 -> pure $ Just ()
+            hPutStrLn stderr ("HTTP server " <> url <> " replied with status code "
-            _ -> sleep *> pure Nothing
+                <> show (HTTP.statusCode (HTTP.getResponseStatus resp)) <> ".")
+            exitFailure
+        Left _ -> do
+            sleep
+            status <- getProcessExitCode processHandle
+            case status of
+                Nothing -> waitForHttpServer (numTries-1) processHandle sleep url headers
+                Just exitCode -> do
+                    hPutStrLn stderr ("Failed to connect to HTTP server " <> url
+                        <> " before process exited with " <> show exitCode)
+                    exitFailure
     where isIOException e = isJust (fromException e :: Maybe IOException)
           isHttpException e = isJust (fromException e :: Maybe HTTP.HttpException)
 

daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs

@@ -65,7 +65,7 @@ hardcodedToken alice = tokenFor [T.pack alice] "sandbox" "AssistantIntegrationTe
 authorizationHeaders :: String -> RequestHeaders
 authorizationHeaders alice = [("Authorization", "Bearer " <> T.encodeUtf8 (hardcodedToken alice))]
 
-withDamlServiceIn :: FilePath -> String -> [String] -> IO a -> IO a
+withDamlServiceIn :: FilePath -> String -> [String] -> (ProcessHandle -> IO a) -> IO a
 withDamlServiceIn path command args act = withDevNull $ \devNull -> do
     let proc' = (shell $ unwords $ ["daml", command] <> args)
           { std_out = UseHandle devNull
@@ -73,7 +73,7 @@ withDamlServiceIn path command args act = withDevNull $ \devNull -> do
           , cwd = Just path
           }
     withCreateProcess proc' $ \_ _ _ ph -> do
-        r <- act
+        r <- act ph
         interruptProcessGroupOf ph
         pure r
 
@@ -159,8 +159,8 @@ damlStart tmpDir withCantonSandbox = do
     outReader <- forkIO $ forever $ do
         line <- hGetLine startStdout
         atomically $ writeTChan outChan line
-    waitForHttpServer
+    waitForHttpServer 120 startPh
-        (threadDelay 100000)
+        (threadDelay 500000)
         ("http://localhost:" <> show jsonApiPort <> "/v1/query")
         (authorizationHeaders "Alice") -- dummy party here, not important
     scriptOutput <- readFileUTF8 (projDir </> scriptOutputFile)
@@ -207,7 +207,7 @@ quickSandbox projDir = do
                         ])
                     {std_out = UseHandle devNull, create_group = True, cwd = Just projDir}
         (_, _, _, sandboxPh) <- createProcess sandboxProc
-        waitForConnectionOnPort (threadDelay 500000) $ fromIntegral sandboxPort
+        waitForConnectionOnPort 240 sandboxPh (threadDelay 500000) $ fromIntegral sandboxPort
         pure $
             QuickSandboxResource
                 { quickProjDir = projDir
@@ -359,10 +359,10 @@ damlToolTests =
                     , "client-id"
                     , "--secret"
                     , "client-secret"
-                    ] $ do
+                    ] $ \ ph -> do
                         let endpoint =
                                 "http://localhost:" <> show middlewarePort <> "/livez"
-                        waitForHttpServer (threadDelay 100000) endpoint []
+                        waitForHttpServer 240 ph (threadDelay 500000) endpoint []
                         req <- parseRequest endpoint
                         manager <- newManager defaultManagerSettings
                         resp <- httpLbs req manager
@@ -456,9 +456,9 @@ damlStartTests getDamlStart =
                 , "--http-port"
                 , show triggerServicePort
                 , "--wall-clock-time"
-                ] $ do
+                ] $ \ ph -> do
                     let endpoint = "http://localhost:" <> show triggerServicePort <> "/livez"
-                    waitForHttpServer (threadDelay 100000) endpoint []
+                    waitForHttpServer 240 ph (threadDelay 500000) endpoint []
                     req <- parseRequest endpoint
                     manager <- newManager defaultManagerSettings
                     resp <- httpLbs req manager
@@ -475,9 +475,9 @@ damlStartTests getDamlStart =
                 , show sandboxPort
                 , "--port"
                 , show navigatorPort
-                ] $ do
+                ] $ \ ph -> do
-                    waitForHttpServer
+                    waitForHttpServer 240 ph
-                        (threadDelay 100000)
+                        (threadDelay 500000)
                         ("http://localhost:" <> show navigatorPort)
                         []
         subtest "Navigator startup via daml ledger outside project directory" $ do
@@ -491,11 +491,11 @@ damlStartTests getDamlStart =
                     , show sandboxPort
                     , "--port"
                     , show navigatorPort
-                    ] $ do
+                    ] $ \ ph -> do
                         -- waitForHttpServer will only return once we get a 200 response so we
                         -- don’t need to do anything else.
-                        waitForHttpServer
+                        waitForHttpServer 240 ph
-                            (threadDelay 100000)
+                            (threadDelay 500000)
                             ("http://localhost:" <> show navigatorPort)
                             []
 
@@ -538,8 +538,8 @@ damlStartNotSharedTest = testCase "daml start --sandbox-port=0" $
             , "--canton-admin-api-port=0"
             , "--canton-domain-public-port=0"
             , "--canton-domain-admin-port=0"
-            ] $ do
+            ] $ \ ph -> do
-                jsonApiPort <- readPortFile maxRetries (tmpDir </> "jsonapi.port")
+                jsonApiPort <- readPortFile ph maxRetries (tmpDir </> "jsonapi.port")
                 initialRequest <-
                     parseRequest $
                     "http://localhost:" <> show jsonApiPort <> "/v1/parties/allocate"
@@ -667,8 +667,8 @@ quickstartTests quickstartDir mvnDir getSandbox =
                 , "--port"
                 , show p
                 , ".daml/dist/quickstart-0.0.1.dar"
-                ] $ do
+                ] $ \ ph -> do
-                    waitForConnectionOnPort (threadDelay 100000) p
+                    waitForConnectionOnPort 240 ph (threadDelay 500000) p
                     addr:_ <- getAddrInfo (Just socketHints) (Just "127.0.0.1") (Just $ show p)
                     bracket
                         (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
@@ -699,7 +699,7 @@ quickstartTests quickstartDir mvnDir getSandbox =
                         , cwd = Just quickProjDir }
                 withCreateProcess mavenProc $ \_ _ _ mavenPh -> do
                     let url = "http://localhost:" <> show restPort <> "/iou"
-                    waitForHttpServer (threadDelay 1000000) url []
+                    waitForHttpServer 240 mavenPh (threadDelay 500000) url []
                     threadDelay 5000000
                     manager <- newManager defaultManagerSettings
                     req <- parseRequest url
@@ -836,9 +836,9 @@ cantonTests = testGroup "daml canton-sandbox"
         , "--domain-public-port", show domainPublicApiPort
         , "--domain-admin-port", show domainAdminApiPort
         , "--port-file", portFile
-        ] $ do
+        ] $ \ ph -> do
         -- wait for port file to be written
-        _ <- readPortFileWith decodeCantonSandboxPort maxRetries portFile
+        _ <- readPortFileWith decodeCantonSandboxPort ph maxRetries portFile
         step "Uploading DAR"
         callCommandSilentIn (dir </> "skeleton") $ unwords
           ["daml ledger upload-dar --host=localhost --port=" <> show ledgerApiPort, ".daml/dist/skeleton-0.0.1.dar"]

libs-haskell/da-hs-base/BUILD.bazel

@@ -35,6 +35,7 @@ da_haskell_library(
         "optparse-applicative",
         "pretty-show",
         "pretty",
+        "process",
         "random",
         "safe",
         "safe-exceptions",

libs-haskell/da-hs-base/src/DA/PortFile.hs

@@ -13,20 +13,38 @@ import Safe (readMay)
 import System.Exit
 import System.IO
 import System.IO.Error
+import System.Process
 
-readPortFileWith :: (String -> Maybe t) -> Int -> String -> IO t
+readOnce :: (String -> Maybe t) -> FilePath -> IO (Maybe t)
-readPortFileWith _ 0 file = do
+readOnce parseFn file = catchJust
+    (guard . shouldCatch)
+    (parseFn <$> readFile file)
+    (const $ pure Nothing)
+
+readPortFileWith :: (String -> Maybe t) -> ProcessHandle -> Int -> FilePath -> IO t
+readPortFileWith _ _ 0 file = do
   T.hPutStrLn stderr ("Port file was not written to '" <> pack file <> "' in time.")
   exitFailure
-readPortFileWith parseFn n file = do
+readPortFileWith parseFn ph n file = do
-  fileContent <- catchJust (guard . shouldCatch) (readFile file) (const $ pure "")
+  result <- readOnce parseFn file
-  case parseFn fileContent of
+  case result of
-    Nothing -> do
-      threadDelay (1000 * retryDelayMillis)
-      readPortFileWith parseFn (n-1) file
     Just p -> pure p
+    Nothing -> do
+      status <- getProcessExitCode ph
+      case status of
+        Nothing -> do -- Process still active. Try again.
+          threadDelay (1000 * retryDelayMillis)
+          readPortFileWith parseFn ph (n-1) file
+        Just exitCode -> do -- Process exited already. Try reading one last time, then give up.
+          threadDelay (1000 * retryDelayMillis)
+          result <- readOnce parseFn file
+          case result of
+            Just p -> pure p
+            Nothing -> do
+              T.hPutStrLn stderr ("Port file was not written to '" <> pack file <> "' before process exit with " <> pack (show exitCode))
+              exitFailure
 
-readPortFile :: Int -> String -> IO Int
+readPortFile :: ProcessHandle -> Int -> FilePath -> IO Int
 readPortFile = readPortFileWith readMay
 
 -- On Windows we sometimes get permission errors. It looks like

libs-haskell/test-utils/DA/Test/HttpJson.hs

@@ -58,10 +58,10 @@ createHttpJson httpJsonOutput getLedgerPort HttpJsonConfig {actor, mbSharedSecre
   writeFileUTF8 tokenFile $ T.unpack token
   httpJsonProc <- getHttpJsonProc getLedgerPort portFile
   mask $ \unmask -> do
-    ph <- createProcess httpJsonProc {std_out = UseHandle httpJsonOutput}
+    ph@(_,_,_,ph') <- createProcess httpJsonProc {std_out = UseHandle httpJsonOutput}
     let cleanup = cleanupProcess ph >> rmTmpDir
     let waitForStart = do
-          port <- readPortFile maxRetries portFile
+          port <- readPortFile ph' maxRetries portFile
           pure
             (HttpJsonResource
                { httpJsonProcess = ph

libs-haskell/test-utils/DA/Test/Sandbox.hs

@@ -88,9 +88,9 @@ createSandbox :: FilePath -> Handle -> SandboxConfig -> IO SandboxResource
 createSandbox portFile sandboxOutput conf = do
     sandboxProc <- getSandboxProc conf portFile
     mask $ \unmask -> do
-        ph <- createProcess sandboxProc { std_out = UseHandle sandboxOutput }
+        ph@(_,_,_,ph') <- createProcess sandboxProc { std_out = UseHandle sandboxOutput }
         let waitForStart = do
-                port <- readPortFile maxRetries portFile
+                port <- readPortFile ph' maxRetries portFile
                 pure (SandboxResource ph port)
         unmask (waitForStart `onException` cleanupProcess ph)