From 32bd807838c3070ff4727f9b82e39ff6549b4670 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 27 Aug 2025 04:21:15 +0800 Subject: [PATCH 1/2] Replace writeFile and writeFileUTF8 with atomicFileWriteString and atomicFileWriteStringUTF8 for safer file operations --- ghcide-test/exe/CradleTests.hs | 11 +++++---- ghcide-test/exe/DependentFileTest.hs | 5 ++-- ghcide-test/exe/DiagnosticTests.hs | 4 ++-- ghcide-test/exe/GarbageCollectionTests.hs | 11 +++++---- ghcide-test/exe/IfaceTests.hs | 3 ++- ghcide-test/exe/PluginSimpleTests.hs | 3 ++- ghcide-test/exe/UnitTests.hs | 5 ++-- ghcide-test/exe/WatchedFileTests.hs | 12 +++++----- hls-test-utils/src/Test/Hls/FileSystem.hs | 28 +++++++++++++++++++++++ 9 files changed, 58 insertions(+), 24 deletions(-) diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs index d79b90c835..8edb258257 100644 --- a/ghcide-test/exe/CradleTests.hs +++ b/ghcide-test/exe/CradleTests.hs @@ -29,6 +29,7 @@ import Language.LSP.Protocol.Types hiding import Language.LSP.Test import System.FilePath import System.IO.Extra hiding (withTempDir) +import Test.Hls.FileSystem import Test.Hls.Util (EnvSpec (..), OS (..), ignoreInEnv) import Test.Tasty @@ -53,7 +54,7 @@ loadCradleOnlyonce = testGroup "load cradle only once" ] where direct dir = do - liftIO $ writeFileUTF8 (dir "hie.yaml") + liftIO $ atomicFileWriteStringUTF8 (dir "hie.yaml") "cradle: {direct: {arguments: []}}" test dir implicit dir = test dir @@ -73,7 +74,7 @@ retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do -- The false cradle always fails let hieContents = "cradle: {bios: {shell: \"false\"}}" hiePath = dir "hie.yaml" - liftIO $ writeFile hiePath hieContents + liftIO $ atomicFileWriteString hiePath hieContents let aPath = dir "A.hs" doc <- createDoc aPath "haskell" "main = return ()" WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc @@ -81,7 +82,7 @@ retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do -- Fix the cradle and typecheck again let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" - liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle + liftIO $ atomicFileWriteStringUTF8 hiePath $ T.unpack validCradle sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] @@ -214,7 +215,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty' "session-deps-are-picked-up" $ \dir -> do liftIO $ - writeFileUTF8 + atomicFileWriteStringUTF8 (dir "hie.yaml") "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error. @@ -223,7 +224,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty' -- Update hie.yaml to enable OverloadedStrings. liftIO $ - writeFileUTF8 + atomicFileWriteStringUTF8 (dir "hie.yaml") "cradle: {direct: {arguments: [-XOverloadedStrings]}}" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams diff --git a/ghcide-test/exe/DependentFileTest.hs b/ghcide-test/exe/DependentFileTest.hs index 1f243819e3..dd2cb2a046 100644 --- a/ghcide-test/exe/DependentFileTest.hs +++ b/ghcide-test/exe/DependentFileTest.hs @@ -15,6 +15,7 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import Test.Hls +import Test.Hls.FileSystem tests :: TestTree @@ -31,7 +32,7 @@ tests = testGroup "addDependentFile" -- If the file contains B then no type error -- otherwise type error let depFilePath = "dep-file.txt" - liftIO $ writeFile depFilePath "A" + liftIO $ atomicFileWriteString depFilePath "A" let fooContent = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" , "module Foo where" @@ -48,7 +49,7 @@ tests = testGroup "addDependentFile" expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Just "GHC-83865")])] -- Now modify the dependent file - liftIO $ writeFile depFilePath "B" + liftIO $ atomicFileWriteString depFilePath "B" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ] diff --git a/ghcide-test/exe/DiagnosticTests.hs b/ghcide-test/exe/DiagnosticTests.hs index df05fdd61d..a0e9ae2768 100644 --- a/ghcide-test/exe/DiagnosticTests.hs +++ b/ghcide-test/exe/DiagnosticTests.hs @@ -39,7 +39,7 @@ import System.Time.Extra import Test.Hls (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor), runSessionWithTestConfig, waitForProgressBegin) -import Test.Hls.FileSystem (directCradle, file, text) +import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.HUnit @@ -381,7 +381,7 @@ tests = testGroup "diagnostics" let (drive, suffix) = splitDrive pathB in filePathToUri (joinDrive (lower drive) suffix) liftIO $ createDirectoryIfMissing True (takeDirectory pathB) - liftIO $ writeFileUTF8 pathB $ T.unpack bContent + liftIO $ atomicFileWriteStringUTF8 pathB $ T.unpack bContent uriA <- getDocUri "A/A.hs" Just pathA <- pure $ uriToFilePath uriA uriA <- pure $ diff --git a/ghcide-test/exe/GarbageCollectionTests.hs b/ghcide-test/exe/GarbageCollectionTests.hs index 5cc9935352..1a867ad747 100644 --- a/ghcide-test/exe/GarbageCollectionTests.hs +++ b/ghcide-test/exe/GarbageCollectionTests.hs @@ -12,6 +12,7 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test import System.FilePath +import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.HUnit import Text.Printf (printf) @@ -20,14 +21,14 @@ tests :: TestTree tests = testGroup "garbage collection" [ testGroup "dirty keys" [ testWithDummyPluginEmpty' "are collected" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + liftIO $ atomicFileWriteString (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" doc <- generateGarbage "A" dir closeDoc doc garbage <- waitForGC liftIO $ assertBool "no garbage was found" $ not $ null garbage , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + liftIO $ atomicFileWriteString (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir keys0 <- getStoredKeys closeDoc docA @@ -37,7 +38,7 @@ tests = testGroup "garbage collection" liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" + liftIO $ atomicFileWriteString (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" docA <- generateGarbage "A" dir _docB <- generateGarbage "B" dir @@ -58,7 +59,7 @@ tests = testGroup "garbage collection" liftIO $ regeneratedKeys @?= mempty , testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + liftIO $ atomicFileWriteString (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir closeDoc docA garbage <- waitForGC @@ -83,7 +84,7 @@ tests = testGroup "garbage collection" let fp = modName <> ".hs" body = printf "module %s where" modName doc <- createDoc fp "haskell" (T.pack body) - liftIO $ writeFile (dir fp) body + liftIO $ atomicFileWriteString (dir fp) body builds <- waitForTypecheck doc liftIO $ assertBool "something is wrong with this test" builds return doc diff --git a/ghcide-test/exe/IfaceTests.hs b/ghcide-test/exe/IfaceTests.hs index d7dc533550..e1e94c926d 100644 --- a/ghcide-test/exe/IfaceTests.hs +++ b/ghcide-test/exe/IfaceTests.hs @@ -18,6 +18,7 @@ import Language.LSP.Test import System.Directory import System.FilePath import System.IO.Extra hiding (withTempDir) +import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.HUnit @@ -45,7 +46,7 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do cdoc <- createDoc cPath "haskell" cSource -- Change [TH]a from () to Bool - liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) + liftIO $ atomicFileWriteStringUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) -- Check that the change propagates to C changeDoc cdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument cSource] diff --git a/ghcide-test/exe/PluginSimpleTests.hs b/ghcide-test/exe/PluginSimpleTests.hs index c160d2461c..b15e9af749 100644 --- a/ghcide-test/exe/PluginSimpleTests.hs +++ b/ghcide-test/exe/PluginSimpleTests.hs @@ -9,6 +9,7 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test import System.FilePath +import Test.Hls.FileSystem import Test.Tasty tests :: TestTree @@ -36,7 +37,7 @@ tests = -- required by plugin-1.0.0). See the build log above for details. testWithExtraFiles "simple plugin" "plugin-knownnat" $ \dir -> do _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ writeFile (dir"hie.yaml") + liftIO $ atomicFileWriteString (dir"hie.yaml") "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" expectDiagnostics diff --git a/ghcide-test/exe/UnitTests.hs b/ghcide-test/exe/UnitTests.hs index b2940ab27f..dcd5c170f4 100644 --- a/ghcide-test/exe/UnitTests.hs +++ b/ghcide-test/exe/UnitTests.hs @@ -31,6 +31,7 @@ import System.Mem (performGC) import Test.Hls (IdeState, def, runSessionWithServerInTmpDir, waitForProgressDone) +import Test.Hls.FileSystem import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -104,9 +105,9 @@ findResolution_us :: Int -> IO Int findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do performGC - writeFile f "" + atomicFileWriteString f "" threadDelay delay_us - writeFile f' "" + atomicFileWriteString f' "" t <- getModTime f t' <- getModTime f' if t /= t' then return delay_us else findResolution_us (delay_us * 10) diff --git a/ghcide-test/exe/WatchedFileTests.hs b/ghcide-test/exe/WatchedFileTests.hs index 1c2ded9109..f00e4bfffe 100644 --- a/ghcide-test/exe/WatchedFileTests.hs +++ b/ghcide-test/exe/WatchedFileTests.hs @@ -29,7 +29,7 @@ tests :: TestTree tests = testGroup "watched files" [ testGroup "Subscriptions" [ testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" + liftIO $ atomicFileWriteString (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" setIgnoringRegistrationRequests False watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics @@ -40,7 +40,7 @@ tests = testGroup "watched files" , testWithDummyPluginEmpty' "non workspace file" $ \sessionDir -> do tmpDir <- liftIO getTemporaryDirectory let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" - liftIO $ writeFile (sessionDir "hie.yaml") yaml + liftIO $ atomicFileWriteString (sessionDir "hie.yaml") yaml _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" setIgnoringRegistrationRequests False watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics @@ -53,8 +53,8 @@ tests = testGroup "watched files" , testGroup "Changes" [ testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" - liftIO $ writeFile (sessionDir "B.hs") $ unlines + liftIO $ atomicFileWriteString (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" + liftIO $ atomicFileWriteString (sessionDir "B.hs") $ unlines ["module B where" ,"b :: Bool" ,"b = False"] @@ -66,7 +66,7 @@ tests = testGroup "watched files" ] expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")])] -- modify B off editor - liftIO $ writeFile (sessionDir "B.hs") $ unlines + liftIO $ atomicFileWriteString (sessionDir "B.hs") $ unlines ["module B where" ,"b :: Int" ,"b = 0"] @@ -80,7 +80,7 @@ tests = testGroup "watched files" let cabalFile = "reload.cabal" cabalContent <- liftIO $ T.readFile cabalFile let fix = T.replace "build-depends: base" "build-depends: base, split" - liftIO $ T.writeFile cabalFile (fix cabalContent) + liftIO $ atomicFileWriteText cabalFile (fix cabalContent) sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [ FileEvent (filePathToUri $ sessionDir cabalFile) FileChangeType_Changed ] expectDiagnostics [(hsFile, [])] diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index c93643badd..8a6193904f 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -29,8 +29,12 @@ module Test.Hls.FileSystem , directProjectMulti , simpleCabalProject , simpleCabalProject' + , atomicFileWriteString + , atomicFileWriteStringUTF8 + , atomicFileWriteText ) where +import Control.Exception (onException) import Data.Foldable (traverse_) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -38,6 +42,7 @@ import Development.IDE (NormalizedFilePath) import Language.LSP.Protocol.Types (toNormalizedFilePath) import System.Directory import System.FilePath as FP +import System.IO.Extra (newTempFileWithin, writeFileUTF8) import System.Process.Extra (readProcess) -- ---------------------------------------------------------------------------- @@ -244,3 +249,26 @@ simpleCabalProject' :: [FileTree] -> [FileTree] simpleCabalProject' fps = [ simpleCabalCradle ] <> fps + + +-- | Also resets the interface store +atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO a +atomicFileWrite targetPath write = do + let dir = takeDirectory targetPath + createDirectoryIfMissing True dir + (tempFilePath, cleanUp) <- newTempFileWithin dir + (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> pure x) + `onException` cleanUp + + +atomicFileWriteString :: FilePath -> String -> IO () +atomicFileWriteString targetPath content = + atomicFileWrite targetPath (flip writeFile content) + +atomicFileWriteStringUTF8 :: FilePath -> String -> IO () +atomicFileWriteStringUTF8 targetPath content = + atomicFileWrite targetPath (flip writeFileUTF8 content) + +atomicFileWriteText :: FilePath -> T.Text -> IO () +atomicFileWriteText targetPath content = + atomicFileWrite targetPath (flip T.writeFile content) From 37fe94ff744f10a9e08f6450bf0c59d6b8fa15e2 Mon Sep 17 00:00:00 2001 From: patrick Date: Wed, 27 Aug 2025 05:39:46 +0800 Subject: [PATCH 2/2] Update FileSystem.hs --- hls-test-utils/src/Test/Hls/FileSystem.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index 8a6193904f..e349dbad3b 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -251,7 +251,6 @@ simpleCabalProject' fps = ] <> fps --- | Also resets the interface store atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO a atomicFileWrite targetPath write = do let dir = takeDirectory targetPath