diff --git a/hls-test-utils.cabal b/hls-test-utils.cabal --- a/hls-test-utils.cabal +++ b/hls-test-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils -version: 2.13.0.0 +version: 2.14.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -27,8 +27,9 @@ library exposed-modules: Test.Hls - Test.Hls.Util Test.Hls.FileSystem + Test.Hls.TestEnv + Test.Hls.Util Development.IDE.Test Development.IDE.Test.Diagnostic @@ -43,14 +44,15 @@ , directory , extra , filepath - , ghcide == 2.13.0.0 - , hls-plugin-api == 2.13.0.0 + , ghcide == 2.14.0.0 + , hls-plugin-api == 2.14.0.0 , lens , lsp - , lsp-test ^>=0.17 - , lsp-types ^>=2.3 + , lsp-test ^>=0.18 + , lsp-types ^>=2.4 + , primitive , safe-exceptions - , string-interpolate + , string-interpolate >= 0.3.1 , tasty , tasty-expected-failure , tasty-golden diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -29,6 +29,7 @@ goldenWithCabalDocFormatter, goldenWithCabalDocFormatterInTmpDir, goldenWithTestConfig, + hlsHelperTestRecorder, def, -- * Running HLS for integration tests runSessionWithServer, @@ -81,6 +82,7 @@ import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) import Control.Monad.IO.Class +import Control.Monad.Primitive (keepAlive) import Data.Aeson (Result (Success), Value (Null), fromJSON, toJSON) @@ -143,6 +145,8 @@ import System.Time.Extra import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem +import Test.Hls.TestEnv (hlsTestOptions, + wrapCliTestOptions) import Test.Hls.Util import Test.Tasty hiding (Timeout) import Test.Tasty.ExpectedFailure @@ -154,6 +158,17 @@ = LogIDEMain IDEMain.Log | LogTestHarness LogTestHarness +data TestRunLog + = TestRunFinished + | TestServerExitTimeoutSeconds Int + | TestServerCancelFinished String + +instance Pretty TestRunLog where + pretty :: TestRunLog -> Logger.Doc ann + pretty TestRunFinished = "Test run finished" + pretty (TestServerExitTimeoutSeconds secs) = "Server does not exit in " <> pretty secs <> "s, canceling the async task..." + pretty (TestServerCancelFinished took) = "Finishing canceling (took " <> pretty took <> "s)" + instance Pretty Log where pretty = \case LogIDEMain log -> pretty log @@ -180,9 +195,12 @@ unCurrent :: ExpectBroken 'Current a -> a unCurrent (BrokenCurrent a) = a --- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes +-- | Run main with rerun, limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () -defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) +defaultTestRunner = defaultMainWithIngredients ingredientsWithRerun . wrapCliTestOptions . adjustOption (const $ mkTimeout 600000000) + where + ingredients = includingOptions hlsTestOptions : defaultIngredients + ingredientsWithRerun = [rerunningTests ingredients] gitDiff :: FilePath -> FilePath -> [String] gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "--no-index", "--text", "--exit-code", fRef, fNew] @@ -813,13 +831,14 @@ runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a runSessionWithTestConfig TestConfig{..} session = runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do - (inR, inW) <- createPipe - (outR, outW) <- createPipe + pipeIn@(inR, inW) <- createPipe + pipeOut@(outR, outW) <- createPipe let serverRoot = fromMaybe root testServerRoot let clientRoot = fromMaybe root testClientRoot (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder + testRecorder <- hlsHelperTestRecorder -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders let lspRecorderPlugin = pluginDescToIdePlugins [(defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin") @@ -832,18 +851,29 @@ timeoutOverride <- fmap read <$> lookupEnv "LSP_TIMEOUT" let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} arguments = testingArgs serverRoot recorderIde plugins - server <- async $ - IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) - arguments { argsHandleIn = pure inR , argsHandleOut = pure outW } - result <- runSessionWithHandles inW outR sconf' testConfigCaps clientRoot (session root) - hClose inW - timeout 3 (wait server) >>= \case - Just () -> pure () - Nothing -> do - putStrLn "Server does not exit in 3s, canceling the async task..." - (t, _) <- duration $ cancel server - putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" - pure result + + -- Make an explicit call to keepAlive to protect both pipes from being GC'd. + -- + -- If not done, a race condition forms from the handles of either pipe + -- being closed during the LSP shutdown process. For example, consider + -- lsp-test initiates the shutdown process, whereafter ghcide shuts down. + -- If it's write handle is closed due to GC, lsp-test, which has been + -- asynchronously reading from that handle's read end, will encounter a EOF + -- and crash. + keepAlive (pipeIn, pipeOut) $ do + server <- async $ + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) + arguments { argsHandleIn = pure inR , argsHandleOut = pure outW } + result <- runSessionWithHandles inW outR sconf' testConfigCaps clientRoot (session root) + hClose inW + timeout 3 (wait server) >>= \case + Just () -> pure () + Nothing -> do + logWith testRecorder Info (TestServerExitTimeoutSeconds 3) + (t, _) <- duration $ cancel server + logWith testRecorder Info (TestServerCancelFinished (showDuration t)) + logWith testRecorder Info TestRunFinished + pure result where shiftRoot shiftTarget f = diff --git a/src/Test/Hls/TestEnv.hs b/src/Test/Hls/TestEnv.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hls/TestEnv.hs @@ -0,0 +1,104 @@ +module Test.Hls.TestEnv + ( HlsLogStderr(..) + , HlsPluginLogStderr(..) + , HlsHarnessStderr(..) + , HlsHarnessNoTestdirCleanup(..) + , HlsTestRootDir(..) + , LspTimeout(..) + , hlsTestOptions + , wrapCliTestOptions + ) where + +import Control.Monad (guard) +import Data.Data (Proxy (..)) +import Data.Foldable (traverse_) +import Data.Maybe (catMaybes) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import Test.Tasty (TestTree, askOption, withResource) +import Test.Tasty.Options (IsOption (defaultValue, optionCLParser, optionHelp, optionName, parseValue), + OptionDescription (..), flagCLParser, + safeRead, safeReadBool) + +newtype HlsLogStderr = HlsLogStderr Bool +instance IsOption HlsLogStderr where + defaultValue = HlsLogStderr False + parseValue s = HlsLogStderr <$> safeReadBool s + optionName = pure "log-stderr" + optionHelp = pure "Log all HLS messages to stderr" + optionCLParser = flagCLParser Nothing (HlsLogStderr True) + +newtype HlsPluginLogStderr = HlsPluginLogStderr Bool +instance IsOption HlsPluginLogStderr where + defaultValue = HlsPluginLogStderr False + parseValue s = HlsPluginLogStderr <$> safeReadBool s + optionName = pure "plugin-log-stderr" + optionHelp = pure "Log all messages of the hls plugin under test to stderr" + optionCLParser = flagCLParser Nothing (HlsPluginLogStderr True) + +newtype HlsHarnessStderr = HlsHarnessStderr Bool +instance IsOption HlsHarnessStderr where + defaultValue = HlsHarnessStderr False + parseValue s = HlsHarnessStderr <$> safeReadBool s + optionName = pure "test-harness-log-stderr" + optionHelp = pure "Log test setup messages to stderr" + optionCLParser = flagCLParser Nothing (HlsHarnessStderr True) + +newtype HlsHarnessNoTestdirCleanup = HlsHarnessNoTestdirCleanup Bool +instance IsOption HlsHarnessNoTestdirCleanup where + defaultValue = HlsHarnessNoTestdirCleanup False + parseValue s = HlsHarnessNoTestdirCleanup <$> safeReadBool s + optionName = pure "test-harness-no-testdir-cleanup" + optionHelp = pure "Don't remove the test directories after test execution" + optionCLParser = flagCLParser Nothing (HlsHarnessNoTestdirCleanup True) + +newtype HlsTestRootDir = HlsTestRootDir (Maybe FilePath) +instance IsOption HlsTestRootDir where + defaultValue = HlsTestRootDir Nothing + parseValue s = Just . HlsTestRootDir . Just $ s + optionName = pure "test-root-dir" + optionHelp = pure "Root directory for test file isolation" + +newtype LspTimeout = LspTimeout (Maybe Int) +instance IsOption LspTimeout where + defaultValue = LspTimeout Nothing + parseValue s = LspTimeout . Just <$> safeRead s + optionName = pure "lsp-timeout" + optionHelp = pure "Set a specific test timeout in seconds" + +hlsTestOptions :: [OptionDescription] +hlsTestOptions = + [ Option (Proxy @HlsLogStderr) + , Option (Proxy @HlsPluginLogStderr) + , Option (Proxy @HlsHarnessStderr) + , Option (Proxy @HlsHarnessNoTestdirCleanup) + , Option (Proxy @HlsTestRootDir) + , Option (Proxy @LspTimeout) + ] + +-- | Use tasty cli options to set legacy environment variables +wrapCliTestOptions :: TestTree -> TestTree +wrapCliTestOptions tree = + askOption $ \(HlsLogStderr logStderr) -> + askOption $ \(HlsPluginLogStderr pluginStderr) -> + askOption $ \(HlsTestRootDir rootDir) -> + askOption $ \(HlsHarnessStderr harnessStderr) -> + askOption $ \(HlsHarnessNoTestdirCleanup harnessNoTestdirCleanup) -> + askOption $ \(LspTimeout timeout) -> + let overrides = catMaybes + [ ("HLS_TEST_LOG_STDERR", "1") <$ guard logStderr + , ("HLS_TEST_PLUGIN_LOG_STDERR", "1") <$ guard pluginStderr + , ("HLS_TEST_ROOTDIR",) <$> rootDir + , ("HLS_TEST_HARNESS_STDERR", "1") <$ guard harnessStderr + , ("HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP", "1") <$ guard harnessNoTestdirCleanup + , ("LSP_TIMEOUT",) . show <$> timeout + ] + in withResource (setOverrides overrides) restoreEnvs (const tree) + +setOverrides :: [(String, String)] -> IO [(String, Maybe String)] +setOverrides = traverse $ \(k, v) -> do + old <- lookupEnv k + setEnv k v + pure (k, old) + +restoreEnvs :: [(String, Maybe String)] -> IO () +restoreEnvs = traverse_ $ \(k, mv) -> maybe (unsetEnv k) (setEnv k) mv