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.14.0.0 +version: 2.15.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -44,8 +44,8 @@ , directory , extra , filepath - , ghcide == 2.14.0.0 - , hls-plugin-api == 2.14.0.0 + , ghcide == 2.15.0.0 + , hls-plugin-api == 2.15.0.0 , lens , lsp , lsp-test ^>=0.18 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -106,6 +106,9 @@ import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Session (SessionLoadingOptions (..), + getHieDbLocIn) +import Development.IDE.Session.Ghc (getCacheDirsIn) import Development.IDE.Types.Options import GHC.IO.Handle import GHC.TypeLits @@ -134,10 +137,9 @@ import System.Directory (canonicalizePath, createDirectoryIfMissing, getCurrentDirectory, - getTemporaryDirectory, makeAbsolute, setCurrentDirectory) -import System.Environment (lookupEnv, setEnv) +import System.Environment (lookupEnv) import System.FilePath import System.IO.Extra (newTempDirWithin) import System.IO.Unsafe (unsafePerformIO) @@ -145,7 +147,8 @@ import System.Time.Extra import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem -import Test.Hls.TestEnv (hlsTestOptions, +import Test.Hls.TestEnv (getTestRootDir, + hlsTestOptions, wrapCliTestOptions) import Test.Hls.Util import Test.Tasty hiding (Timeout) @@ -533,16 +536,16 @@ {testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right tree} (const act) --- | Same as 'withTemporaryDataAndCacheDirectory', but materialises the given --- 'VirtualFileTree' in the temporary directory. -withVfsTestDataDirectory :: VirtualFileTree -> (FileSystem -> IO a) -> IO a +-- | Like 'withTemporaryDataAndCacheDirectory', but first materialises the given +-- 'VirtualFileTree'. The continuation receives the per-test cache directory. +withVfsTestDataDirectory :: VirtualFileTree -> (FileSystem -> FilePath -> IO a) -> IO a withVfsTestDataDirectory tree act = do - withTemporaryDataAndCacheDirectory $ \tmpRoot -> do + withTemporaryDataAndCacheDirectory $ \tmpRoot cacheDir -> do fs <- FS.materialiseVFT tmpRoot tree - act fs + act fs cacheDir --- | Run an action in a temporary directory. --- Sets the 'XDG_CACHE_HOME' environment variable to a temporary directory as well. +-- | Run an action in a temporary directory, passing it both the test root and a +-- fresh cache directory. -- -- This sets up a temporary directory for HLS tests to run. -- Typically, HLS tests copy their test data into the directory and then launch @@ -550,11 +553,10 @@ -- This makes sure that the tests are run in isolation, which is good for correctness -- but also important to have fast tests. -- --- For improved isolation, we also make sure the 'XDG_CACHE_HOME' environment --- variable points to a temporary directory. So, we never share interface files --- or the 'hiedb' across tests. -withTemporaryDataAndCacheDirectory :: (FilePath -> IO a) -> IO a -withTemporaryDataAndCacheDirectory act = withLock lockForTempDirs $ do +-- For isolation, each test gets its own cache directory wired into the server +-- via 'argsGetHieDbLoc' and 'getCacheDirs'. +withTemporaryDataAndCacheDirectory :: (FilePath -> FilePath -> IO a) -> IO a +withTemporaryDataAndCacheDirectory act = do testRoot <- setupTestEnvironment helperRecorder <- hlsHelperTestRecorder -- Do not clean up the temporary directory if this variable is set to anything but '0'. @@ -562,44 +564,28 @@ cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" let runTestInDir action = case cleanupTempDir of Just val | val /= "0" -> do - (tempDir, cacheHome, _) <- setupTemporaryTestDirectories testRoot - a <- withTempCacheHome cacheHome (action tempDir) + (tempDir, cacheDir, _) <- setupTemporaryTestDirectories testRoot + a <- action tempDir cacheDir logWith helperRecorder Debug LogNoCleanup pure a _ -> do - (tempDir, cacheHome, cleanup) <- setupTemporaryTestDirectories testRoot - a <- withTempCacheHome cacheHome (action tempDir) `finally` cleanup + (tempDir, cacheDir, cleanup) <- setupTemporaryTestDirectories testRoot + a <- action tempDir cacheDir `finally` cleanup logWith helperRecorder Debug LogCleanup pure a - runTestInDir $ \tmpDir' -> do + runTestInDir $ \tmpDir' cacheDir -> do -- we canonicalize the path, so that we do not need to do -- canonicalization during the test when we compare two paths tmpDir <- canonicalizePath tmpDir' logWith helperRecorder Info $ LogTestDir tmpDir - act tmpDir + act tmpDir cacheDir where - cache_home_var = "XDG_CACHE_HOME" - -- Set the dir for "XDG_CACHE_HOME". - -- When the operation finished, make sure the old value is restored. - withTempCacheHome tempCacheHomeDir act = - bracket - (do - old_cache_home <- lookupEnv cache_home_var - setEnv cache_home_var tempCacheHomeDir - pure old_cache_home) - (\old_cache_home -> - maybe (pure ()) (setEnv cache_home_var) old_cache_home - ) - (\_ -> act) - - -- Set up a temporary directory for the test files and one for the 'XDG_CACHE_HOME'. - -- The 'XDG_CACHE_HOME' is important for independent test runs, i.e. completely empty - -- caches. + -- A fresh cache directory per test gives empty, independent caches. setupTemporaryTestDirectories testRoot = do (tempTestCaseDir, cleanup1) <- newTempDirWithin testRoot - (tempCacheHomeDir, cleanup2) <- newTempDirWithin testRoot - pure (tempTestCaseDir, tempCacheHomeDir, cleanup1 >> cleanup2) + (tempCacheDir, cleanup2) <- newTempDirWithin testRoot + pure (tempTestCaseDir, tempCacheDir, cleanup1 >> cleanup2) runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = @@ -634,16 +620,9 @@ -- However, it is totally safe to delete the directory between runs. setupTestEnvironment :: IO FilePath setupTestEnvironment = do - mRootDir <- lookupEnv "HLS_TEST_ROOTDIR" - case mRootDir of - Nothing -> do - tmpDirRoot <- getTemporaryDirectory - let testRoot = tmpDirRoot "hls-test-root" - createDirectoryIfMissing True testRoot - pure testRoot - Just rootDir -> do - createDirectoryIfMissing True rootDir - pure rootDir + testRoot <- getTestRootDir + createDirectoryIfMissing True testRoot + pure testRoot goldenWithHaskellDocFormatter :: Pretty b @@ -750,12 +729,6 @@ lock :: Lock lock = unsafePerformIO newLock - -{-# NOINLINE lockForTempDirs #-} --- | Never run in parallel -lockForTempDirs :: Lock -lockForTempDirs = unsafePerformIO newLock - data TestConfig b = TestConfig { testDirLocation :: Either FilePath VirtualFileTree @@ -830,7 +803,7 @@ -- For more detail of the test configuration, see 'TestConfig' runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a runSessionWithTestConfig TestConfig{..} session = - runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do + runSessionInVFS testDirLocation $ \root cacheDir -> shiftRoot root $ do pipeIn@(inR, inW) <- createPipe pipeOut@(outR, outW) <- createPipe let serverRoot = fromMaybe root testServerRoot @@ -850,7 +823,7 @@ let plugins = testPluginDescriptor recorder <> lspRecorderPlugin timeoutOverride <- fmap read <$> lookupEnv "LSP_TIMEOUT" let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} - arguments = testingArgs serverRoot recorderIde plugins + arguments = testingArgs serverRoot cacheDir recorderIde plugins -- Make an explicit call to keepAlive to protect both pipes from being GC'd. -- @@ -882,13 +855,13 @@ else f runSessionInVFS (Left testConfigRoot) act = do root <- makeAbsolute testConfigRoot - withTemporaryDataAndCacheDirectory (const $ act root) + withTemporaryDataAndCacheDirectory (\_ cacheDir -> act root cacheDir) runSessionInVFS (Right vfs) act = - withVfsTestDataDirectory vfs $ \fs -> do - act (fsRoot fs) - testingArgs prjRoot recorderIde plugins = + withVfsTestDataDirectory vfs $ \fs cacheDir -> do + act (fsRoot fs) cacheDir + testingArgs prjRoot cacheDir recorderIde plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot plugins + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions, argsSessionLoadingOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot plugins argsHlsPlugins' = if testDisableDefaultPlugin then plugins else argsHlsPlugins @@ -906,6 +879,13 @@ , argsDefaultHlsConfig = testLspConfig , argsProjectRoot = prjRoot , argsDisableKick = testDisableKick + -- Keep interface files and the hiedb under this test's cache + -- directory instead of the shared 'XDG_CACHE_HOME'. + , argsGetHieDbLoc = getHieDbLocIn cacheDir + , argsSessionLoadingOptions = argsSessionLoadingOptions + { getCacheDirs = \prefix mFirstHash opts -> + pure $ getCacheDirsIn cacheDir prefix mFirstHash opts + } } -- | Wait for the next progress begin step diff --git a/src/Test/Hls/FileSystem.hs b/src/Test/Hls/FileSystem.hs --- a/src/Test/Hls/FileSystem.hs +++ b/src/Test/Hls/FileSystem.hs @@ -19,6 +19,7 @@ , copy , directory , text + , sources , ref , copyDir -- * Cradle helpers @@ -178,9 +179,13 @@ directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes --- | Write the given test directly into a file. +-- | Write the given text directly into a file. text :: T.Text -> Content text = Inline + +-- | Write the given lines directly into a file. +sources :: [T.Text] -> Content +sources = Inline . T.unlines -- | Read the contents of the given file -- The filepath is always resolved to the root of the test data dir. diff --git a/src/Test/Hls/TestEnv.hs b/src/Test/Hls/TestEnv.hs --- a/src/Test/Hls/TestEnv.hs +++ b/src/Test/Hls/TestEnv.hs @@ -7,13 +7,18 @@ , LspTimeout(..) , hlsTestOptions , wrapCliTestOptions + , getTestRootDir ) where import Control.Monad (guard) import Data.Data (Proxy (..)) import Data.Foldable (traverse_) import Data.Maybe (catMaybes) +import System.Directory (createDirectoryIfMissing, + getTemporaryDirectory, makeAbsolute, + removePathForcibly) import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) import Test.Tasty (TestTree, askOption, withResource) import Test.Tasty.Options (IsOption (defaultValue, optionCLParser, optionHelp, optionName, parseValue), OptionDescription (..), flagCLParser, @@ -92,7 +97,37 @@ , ("HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP", "1") <$ guard harnessNoTestdirCleanup , ("LSP_TIMEOUT",) . show <$> timeout ] - in withResource (setOverrides overrides) restoreEnvs (const tree) + in withRunEnv overrides tree + +-- | Root directory for all test files. Honours 'HLS_TEST_ROOTDIR', else the +-- system temp directory. +getTestRootDir :: IO FilePath +getTestRootDir = do + mRootDir <- lookupEnv "HLS_TEST_ROOTDIR" + makeAbsolute =<< case mRootDir of + Just rootDir -> pure rootDir + Nothing -> ( "hls-test-root") <$> getTemporaryDirectory + +-- | Apply the per-run environment around the wrapped tests, then restore it and +-- drop the hie-bios cache. +-- +-- NB: Needs to be applied once, before any test thread starts, because mutating +-- the process environment is inherently thread-unsafe. +withRunEnv :: [(String, String)] -> TestTree -> TestTree +withRunEnv overrides tree = withResource acquire release (const tree) + where + acquire = do + saved <- setOverrides overrides + hieBiosCacheDir <- ( "hie-bios") <$> getTestRootDir + createDirectoryIfMissing True hieBiosCacheDir + -- TODO: Until the following PR is merged, tests cannot run concurrently + -- using this single directory: https://github.com/haskell/hie-bios/pull/520 + savedHieBios <- setOverrides [("HIE_BIOS_CACHE_DIR", hieBiosCacheDir)] + pure (saved ++ savedHieBios, hieBiosCacheDir) + + release (saved, hieBiosCacheDir) = do + restoreEnvs saved + removePathForcibly hieBiosCacheDir setOverrides :: [(String, String)] -> IO [(String, Maybe String)] setOverrides = traverse $ \(k, v) -> do