digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-11-13 22:34:31 +03:00
Code Issues Projects Releases Wiki Activity

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

Browse Source 
* 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
This commit is contained in:
Sofia Faro 2022-01-12 10:01:56 +00:00 committed by GitHub
parent 8bc5804520
commit 09013eb501
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 109 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bazel_tools/client_server/runner_with_port_file/Main.hs
View File

@ -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
port <- readPortFile maxRetries portFile
withCreateProcess serverProc $ \_stdin _stdout _stderr ph -> do
port <- readPortFile ph maxRetries portFile
let interpolatedClientArgs = map (replace "%PORT%" (show port)) splitClientArgs
callProcess clientExe interpolatedClientArgs

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

@ -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

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

@ -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 (putStr "." *> threadDelay 500000) (navigatorURL navigatorPort) []
waitForHttpServer 240 (unsafeProcessHandle ph) (putStr "." *> threadDelay 500000)
(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

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

@ -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.
-- Between each connection request it calls `sleep`.
waitForConnectionOnPort :: IO () -> Int -> IO ()
waitForConnectionOnPort sleep port = do
-- | `waitForConnectionOnPort numTries processHandle sleep port` tries to establish a TCP connection
-- on the given port, in a given number of tries. Between each connection request it checks that a
-- certain process is still alive and calls `sleep`.
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
case r of
Left _ -> sleep *> pure Nothing
Right _ -> pure $ Just ()
r <- tryIO $ checkConnection addr
case r of
Right _ -> pure ()
Left _ -> do
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.
-- Between each connection request it calls `sleep`.
waitForHttpServer :: IO () -> String -> HTTP.RequestHeaders -> IO ()
waitForHttpServer sleep url headers = do
-- | `waitForHttpServer numTries processHandle sleep url headers` tries to establish an HTTP connection on
-- the given URL with the given headers, in a given number of tries. Between each connection request
-- it checks that a certain process is still alive and calls `sleep`.
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
case r of
Right resp
| HTTP.statusCode (HTTP.getResponseStatus resp) == 200 -> pure $ Just ()
_ -> sleep *> pure Nothing
r <- tryJust (\e -> guard (isIOException e || isHttpException e)) $ HTTP.httpNoBody request
case r of
Right resp | HTTP.statusCode (HTTP.getResponseStatus resp) == 200 -> pure ()
Right resp -> do
hPutStrLn stderr ("HTTP server " <> url <> " replied with status code "
<> 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)

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

@ -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
(threadDelay 100000)
waitForHttpServer 120 startPh
(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
waitForHttpServer
(threadDelay 100000)
] $ \ ph -> do
waitForHttpServer 240 ph
(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
(threadDelay 100000)
waitForHttpServer 240 ph
(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
jsonApiPort <- readPortFile maxRetries (tmpDir </> "jsonapi.port")
] $ \ ph -> do
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
waitForConnectionOnPort (threadDelay 100000) p
] $ \ ph -> do
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"]

1
libs-haskell/da-hs-base/BUILD.bazel
View File

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

36
libs-haskell/da-hs-base/src/DA/PortFile.hs
View File

@ -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
readPortFileWith _ 0 file = do
readOnce :: (String -> Maybe t) -> FilePath -> IO (Maybe t)
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
fileContent <- catchJust (guard . shouldCatch) (readFile file) (const $ pure "")
case parseFn fileContent of
Nothing -> do
threadDelay (1000 * retryDelayMillis)
readPortFileWith parseFn (n-1) file
readPortFileWith parseFn ph n file = do
result <- readOnce parseFn file
case result of
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

4
libs-haskell/test-utils/DA/Test/HttpJson.hs
View File

@ -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

4
libs-haskell/test-utils/DA/Test/Sandbox.hs
View File

@ -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)