diff --git a/compiler/lsp-tests/src/Main.hs b/compiler/lsp-tests/src/Main.hs index 50861c4f50..7f50bebbe2 100644 --- a/compiler/lsp-tests/src/Main.hs +++ b/compiler/lsp-tests/src/Main.hs @@ -663,9 +663,8 @@ scriptTests runScripts = testGroup "scripts" closeDoc script closeDoc main' - -- TODO https://github.com/digital-asset/daml/issues/16772 - , localOption (mkTimeout 30000000) $ -- 30s timeout - testCaseSteps "scenario service interrupts on non-script messages" $ \step -> runScripts $ \_stderr -> do + , localOption (mkTimeout 60000000) $ -- 60s timeout + testCaseSteps "scenario service does not interrupt on non-script messages" $ \step -> runScripts $ \_stderr -> do -- open document with long-running script main' <- openDoc' "Main.daml" damlId $ T.unlines @@ -705,14 +704,10 @@ scriptTests runScripts = testGroup "scripts" _ <- sendRequest STextDocumentHover (HoverParams main' (Position 4 3) Nothing) liftIO $ step "Hover sent..." - -- check that new script is started - _ <- liftIO $ hTakeUntil _stderr "SCENARIO SERVICE STDOUT: Script started." - liftIO $ step "New script started." - - -- check that previous script is cancelled - _ <- liftIO $ hTakeUntil _stderr "SCENARIO SERVICE STDOUT: Script cancelling." - _ <- liftIO $ hTakeUntil _stderr "SCENARIO SERVICE STDOUT: Script cancelled." - liftIO $ step "Previous script cancelled." + -- Check that script did return and that log does not show any cancellations + _changeResult <- waitForScriptDidChange + _scriptFinishedMessage <- liftIO $ assertUntilWithout _stderr "SCENARIO SERVICE STDOUT: Script finished." "SCENARIO SERVICE STDOUT: Script cancelled." + liftIO $ step "Script returned without cancellation." closeDoc script closeDoc main' @@ -730,9 +725,32 @@ hTakeUntil handle regex = go line <- hGetLine handle if pred line then pure (Just line) else go +-- Takes lines from the handle until matching the first pattern `until`. If any +-- of the lines before the matching line match the second pattern `without` +-- then fail the test +-- Useful for cases where we want to assert that some message has been emitted +-- without a different message being emitted in the interim, e.g. a script +-- finished without restarts in between. +assertUntilWithout :: Handle -> T.Text -> T.Text -> IO (Maybe String) +assertUntilWithout handle until without = go + where + untilP = matchTest (makeRegex until :: Regex) + withoutP = matchTest (makeRegex without :: Regex) + go = do + closed <- hIsClosed handle + if closed + then pure Nothing + else do + line <- hGetLine handle + if withoutP line then + assertFailure $ "Source line: `" <> line <> "` shouldn't match regular expression `" <> T.unpack without <> "`, but it does." + else if untilP line then + pure (Just line) + else go + assertRegex :: T.Text -> T.Text -> Assertion assertRegex source regex = - let errMsg = "Source text: `" <> T.unpack source <> "` does not match regular expression `" <> T.unpack regex <> "`." + let errMsg = "Source text: `" <> T.unpack source <> "` should match regular expression `" <> T.unpack regex <> "`, but it doesn't." in assertBool errMsg diff --git a/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient.hs b/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient.hs index 011bef53fc..dde562cd6c 100644 --- a/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient.hs +++ b/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient.hs @@ -88,7 +88,26 @@ data Handle = Handle , hContextId :: IORef LowLevel.ContextId -- ^ The root context id, this is mutable so that rather than mutating the context -- we can clone it and update the clone which allows us to safely interrupt a context update. - , hRunningHandlers :: MVar (MS.Map RunOptions (ThreadId, MVar Bool)) + , hRunningHandlers :: MVar (MS.Map RunOptions RunInfo) + -- ^ Track running scripts as a map between the RunOptions that triggered + -- them and all information required to cancel them or to resume from them + -- ContextId for determining ThreadId for cancelling via asynchronous exception + } + +-- RunInfo stores information required for cancelling and resuming from script runs +data RunInfo = RunInfo + { threadId :: ThreadId + , context :: LowLevel.ContextId + -- ^ If a new prospective script run has a newer context id, then threads + -- with older contexts should be cancelled + , stop :: MVar Bool + -- ^ To cancel a thread, put True into this semaphore, which triggers + -- cancellation in the corresponding lowlevel script run + , result :: Barrier (Either LowLevel.Error LowLevel.ScenarioResult) + -- ^ To obtain the result of a script run, listen to this barrier, which will + -- be filled by the lowlevel script run when the script run terminates + -- Must be a barrier so that both this run and future runs can subscribe to + -- the same value. } withSem :: QSemN -> IO a -> IO a @@ -262,36 +281,52 @@ runLiveScript h ctxId logger name statusUpdateHandler = runWithOptions (RunOptio runWithOptions :: RunOptions -> Handle -> LowLevel.ContextId -> IDELogger.Logger -> IO (Either LowLevel.Error LowLevel.ScenarioResult) runWithOptions options Handle{..} ctxId logger = do - resVar <- newEmptyMVar + resBarrier <- newBarrier stopSemaphore <- newEmptyMVar -- If the internal or external thread receives a cancellation exception, signal to stop modifyMVar_ hRunningHandlers $ \runningHandlers -> do - handlerThread <- forkIO $ withSem hConcurrencySem $ do - r <- try $ optionsToLowLevel options hLowLevelHandle ctxId logger stopSemaphore - putMVar resVar $ - case r of - Left ex -> Left $ LowLevel.ExceptionError ex - Right r -> r - pure () + -- If there was an old thread handling the same scenario in the same + -- way, under a different context, send a cancellation to its semaphore + let mbOldRunInfo = MS.lookup options runningHandlers + case mbOldRunInfo of + Just oldRunInfo + | context oldRunInfo == ctxId -> pure () + | otherwise -> do + _ <- tryPutMVar (stop oldRunInfo) True + pure () + Nothing -> pure () - -- Store the new thread into runningHandlers - let insertLookup kx x t = MS.insertLookupWithKey (\_ a _ -> a) kx x t - let (mbOldThread, newRunningHandlers) = insertLookup options (handlerThread, stopSemaphore) runningHandlers + -- If there was an old thread handling the same scenario in the same + -- way, under a different context, or if there was no old thread, start a + -- new thread to replace it. + -- Otherwise (when there is an old thread with the same context id) listen + -- to that thread's result via its result barrier + case mbOldRunInfo of + Just oldRunInfo + | context oldRunInfo == ctxId -> do + _ <- forkIO $ do + oldResult <- waitBarrier (result oldRunInfo) + signalBarrier resBarrier oldResult + pure runningHandlers + _ -> do + handlerThread <- forkIO $ withSem hConcurrencySem $ do + r <- try $ optionsToLowLevel options hLowLevelHandle ctxId logger stopSemaphore + signalBarrier resBarrier $ + case r of + Left ex -> Left $ LowLevel.ExceptionError ex + Right r -> r - -- If there was an old thread handling the same scenario in the same way, - -- send a cancellation to its semaphore - case mbOldThread of - Just (_, oldThreadSemaphore) -> do - _ <- tryPutMVar oldThreadSemaphore True - pure () - _ -> pure () - - -- Return updated runningHandlers - pure newRunningHandlers - res <- takeMVar resVar - _ <- tryPutMVar stopSemaphore False - pure res + let selfInfo = + RunInfo + { threadId = handlerThread + , context = ctxId + , stop = stopSemaphore + , result = resBarrier + } + let newRunningHandlers = MS.insert options selfInfo runningHandlers + pure newRunningHandlers + waitBarrier resBarrier optionsToLowLevel :: RunOptions -> LowLevel.Handle -> LowLevel.ContextId -> IDELogger.Logger -> MVar Bool -> IO (Either LowLevel.Error LowLevel.ScenarioResult) optionsToLowLevel RunOptions{..} h ctxId logger mask = diff --git a/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs b/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs index c476b87c8c..f71a846e72 100644 --- a/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs +++ b/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs @@ -483,6 +483,7 @@ runBiDiLive runner Handle{..} (ContextId ctxId) name logger stopSemaphore status NoResultUpdate -> loop _ -> pure () pure () + _ <- tryPutMVar stopSemaphore False -- once we exit, stop the semaphore checking thread case response of ClientBiDiResponse _ StatusOk _ -> getFinalResponse ClientBiDiResponse _ status _ -> pure (Left (BackendError (BErrorFail status))) diff --git a/compiler/scenario-service/server/src/main/scala/com/digitalasset/daml/lf/ScenarioServiceMain.scala b/compiler/scenario-service/server/src/main/scala/com/digitalasset/daml/lf/ScenarioServiceMain.scala index a7c3d9cd0f..3a952c2262 100644 --- a/compiler/scenario-service/server/src/main/scala/com/digitalasset/daml/lf/ScenarioServiceMain.scala +++ b/compiler/scenario-service/server/src/main/scala/com/digitalasset/daml/lf/ScenarioServiceMain.scala @@ -143,6 +143,7 @@ object ScriptStream { } internal.onNext(message) internal.onCompleted() + println(f"Script finished.") } override def sendStatus(status: ScenarioStatus): Unit = {} @@ -166,6 +167,7 @@ object ScriptStream { } internal.onNext(message) internal.onCompleted() + println(f"Script finished.") } override def sendStatus(status: ScenarioStatus): Unit = internal.synchronized { @@ -268,9 +270,7 @@ class ScenarioService( println(f"Received error $t") } - override def onCompleted(): Unit = { - println("Completed.") - } + override def onCompleted(): Unit = {} } }