hls-test-utils 2.13.0.0 → 2.14.0.0

raw patch · 3 files changed

+159/−23 lines, 3 filesdep +primitivedep ~ghcidedep ~hls-plugin-apidep ~lsp-testPVP ok

version bump matches the API change (PVP)

Dependencies added: primitive

Dependency ranges changed: ghcide, hls-plugin-api, lsp-test, lsp-types, string-interpolate

API changes (from Hackage documentation)

Files

• hls-test-utils.cabal +9/−7
• src/Test/Hls.hs +46/−16
• src/Test/Hls/TestEnv.hs +104/−0

@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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

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

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