Skip to content

Commit 5550ca5

Browse files
soulomoonsoulomoon
authored
Replace writeFile with atomicFileWrite in ghcide-tests (#4710)
* Replace writeFile and writeFileUTF8 with atomicFileWriteString and atomicFileWriteStringUTF8 for safer file operations
1 parent be30f3e commit 5550ca5

File tree

9 files changed

+57
-24
lines changed

9 files changed

+57
-24
lines changed

‎ghcide-test/exe/CradleTests.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Language.LSP.Protocol.Types hiding
2929
import Language.LSP.Test
3030
import System.FilePath
3131
import System.IO.Extra hiding (withTempDir)
32+
import Test.Hls.FileSystem
3233
import Test.Hls.Util (EnvSpec (..), OS (..),
3334
ignoreInEnv)
3435
import Test.Tasty
@@ -53,7 +54,7 @@ loadCradleOnlyonce = testGroup "load cradle only once"
5354
]
5455
where
5556
direct dir = do
56-
liftIO $ writeFileUTF8 (dir </> "hie.yaml")
57+
liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml")
5758
"cradle: {direct: {arguments: []}}"
5859
test dir
5960
implicit dir = test dir
@@ -73,15 +74,15 @@ retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
7374
-- The false cradle always fails
7475
let hieContents = "cradle: {bios: {shell: \"false\"}}"
7576
hiePath = dir </> "hie.yaml"
76-
liftIO $ writeFile hiePath hieContents
77+
liftIO $ atomicFileWriteString hiePath hieContents
7778
let aPath = dir </> "A.hs"
7879
doc <- createDoc aPath "haskell" "main = return ()"
7980
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
8081
liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess
8182

8283
-- Fix the cradle and typecheck again
8384
let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"
84-
liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle
85+
liftIO $ atomicFileWriteStringUTF8 hiePath $ T.unpack validCradle
8586
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
8687
[FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]
8788

@@ -214,7 +215,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty'
214215
"session-deps-are-picked-up"
215216
$ \dir -> do
216217
liftIO $
217-
writeFileUTF8
218+
atomicFileWriteStringUTF8
218219
(dir </> "hie.yaml")
219220
"cradle: {direct: {arguments: []}}"
220221
-- Open without OverloadedStrings and expect an error.
@@ -223,7 +224,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty'
223224

224225
-- Update hie.yaml to enable OverloadedStrings.
225226
liftIO $
226-
writeFileUTF8
227+
atomicFileWriteStringUTF8
227228
(dir </> "hie.yaml")
228229
"cradle: {direct: {arguments: [-XOverloadedStrings]}}"
229230
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams

‎ghcide-test/exe/DependentFileTest.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ import Language.LSP.Protocol.Types hiding
1515
mkRange)
1616
import Language.LSP.Test
1717
import Test.Hls
18+
import Test.Hls.FileSystem
1819

1920

2021
tests :: TestTree
@@ -31,7 +32,7 @@ tests = testGroup "addDependentFile"
3132
-- If the file contains B then no type error
3233
-- otherwise type error
3334
let depFilePath = "dep-file.txt"
34-
liftIO $ writeFile depFilePath "A"
35+
liftIO $ atomicFileWriteString depFilePath "A"
3536
let fooContent = T.unlines
3637
[ "{-# LANGUAGE TemplateHaskell #-}"
3738
, "module Foo where"
@@ -48,7 +49,7 @@ tests = testGroup "addDependentFile"
4849
expectDiagnostics
4950
[("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Just "GHC-83865")])]
5051
-- Now modify the dependent file
51-
liftIO $ writeFile depFilePath "B"
52+
liftIO $ atomicFileWriteString depFilePath "B"
5253
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
5354
[FileEvent (filePathToUri depFilePath) FileChangeType_Changed ]
5455

‎ghcide-test/exe/DiagnosticTests.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,7 @@ import System.Time.Extra
3939
import Test.Hls (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor),
4040
runSessionWithTestConfig,
4141
waitForProgressBegin)
42-
import Test.Hls.FileSystem (directCradle, file, text)
42+
import Test.Hls.FileSystem
4343
import Test.Tasty
4444
import Test.Tasty.HUnit
4545

@@ -381,7 +381,7 @@ tests = testGroup "diagnostics"
381381
let (drive, suffix) = splitDrive pathB
382382
in filePathToUri (joinDrive (lower drive) suffix)
383383
liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
384-
liftIO $ writeFileUTF8 pathB $ T.unpack bContent
384+
liftIO $ atomicFileWriteStringUTF8 pathB $ T.unpack bContent
385385
uriA <- getDocUri "A/A.hs"
386386
Just pathA <- pure $ uriToFilePath uriA
387387
uriA <- pure $

‎ghcide-test/exe/GarbageCollectionTests.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
1212
SemanticTokensEdit (..), mkRange)
1313
import Language.LSP.Test
1414
import System.FilePath
15+
import Test.Hls.FileSystem
1516
import Test.Tasty
1617
import Test.Tasty.HUnit
1718
import Text.Printf (printf)
@@ -20,14 +21,14 @@ tests :: TestTree
2021
tests = testGroup "garbage collection"
2122
[ testGroup "dirty keys"
2223
[ testWithDummyPluginEmpty' "are collected" $ \dir -> do
23-
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
24+
liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
2425
doc <- generateGarbage "A" dir
2526
closeDoc doc
2627
garbage <- waitForGC
2728
liftIO $ assertBool "no garbage was found" $ not $ null garbage
2829

2930
, testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do
30-
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
31+
liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
3132
docA <- generateGarbage "A" dir
3233
keys0 <- getStoredKeys
3334
closeDoc docA
@@ -37,7 +38,7 @@ tests = testGroup "garbage collection"
3738
liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)
3839

3940
, testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do
40-
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
41+
liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
4142
docA <- generateGarbage "A" dir
4243
_docB <- generateGarbage "B" dir
4344

@@ -58,7 +59,7 @@ tests = testGroup "garbage collection"
5859
liftIO $ regeneratedKeys @?= mempty
5960

6061
, testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do
61-
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
62+
liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
6263
docA <- generateGarbage "A" dir
6364
closeDoc docA
6465
garbage <- waitForGC
@@ -83,7 +84,7 @@ tests = testGroup "garbage collection"
8384
let fp = modName <> ".hs"
8485
body = printf "module %s where" modName
8586
doc <- createDoc fp "haskell" (T.pack body)
86-
liftIO $ writeFile (dir </> fp) body
87+
liftIO $ atomicFileWriteString (dir </> fp) body
8788
builds <- waitForTypecheck doc
8889
liftIO $ assertBool "something is wrong with this test" builds
8990
return doc

‎ghcide-test/exe/IfaceTests.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Language.LSP.Test
1818
import System.Directory
1919
import System.FilePath
2020
import System.IO.Extra hiding (withTempDir)
21+
import Test.Hls.FileSystem
2122
import Test.Tasty
2223
import Test.Tasty.HUnit
2324

@@ -45,7 +46,7 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do
4546
cdoc <- createDoc cPath "haskell" cSource
4647

4748
-- Change [TH]a from () to Bool
48-
liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])
49+
liftIO $ atomicFileWriteStringUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])
4950

5051
-- Check that the change propagates to C
5152
changeDoc cdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument cSource]

‎ghcide-test/exe/PluginSimpleTests.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
99
SemanticTokensEdit (..), mkRange)
1010
import Language.LSP.Test
1111
import System.FilePath
12+
import Test.Hls.FileSystem
1213
import Test.Tasty
1314

1415
tests :: TestTree
@@ -36,7 +37,7 @@ tests =
3637
-- required by plugin-1.0.0). See the build log above for details.
3738
testWithExtraFiles "simple plugin" "plugin-knownnat" $ \dir -> do
3839
_ <- openDoc (dir </> "KnownNat.hs") "haskell"
39-
liftIO $ writeFile (dir</>"hie.yaml")
40+
liftIO $ atomicFileWriteString (dir</>"hie.yaml")
4041
"cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"
4142

4243
expectDiagnostics

‎ghcide-test/exe/UnitTests.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import System.Mem (performGC)
3131
import Test.Hls (IdeState, def,
3232
runSessionWithServerInTmpDir,
3333
waitForProgressDone)
34+
import Test.Hls.FileSystem
3435
import Test.Tasty
3536
import Test.Tasty.ExpectedFailure
3637
import Test.Tasty.HUnit
@@ -104,9 +105,9 @@ findResolution_us :: Int -> IO Int
104105
findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"
105106
findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do
106107
performGC
107-
writeFile f ""
108+
atomicFileWriteString f ""
108109
threadDelay delay_us
109-
writeFile f' ""
110+
atomicFileWriteString f' ""
110111
t <- getModTime f
111112
t' <- getModTime f'
112113
if t /= t' then return delay_us else findResolution_us (delay_us * 10)

‎ghcide-test/exe/WatchedFileTests.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,7 @@ tests :: TestTree
2929
tests = testGroup "watched files"
3030
[ testGroup "Subscriptions"
3131
[ testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do
32-
liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"
32+
liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"
3333
_doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
3434
setIgnoringRegistrationRequests False
3535
watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics
@@ -40,7 +40,7 @@ tests = testGroup "watched files"
4040
, testWithDummyPluginEmpty' "non workspace file" $ \sessionDir -> do
4141
tmpDir <- liftIO getTemporaryDirectory
4242
let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"
43-
liftIO $ writeFile (sessionDir </> "hie.yaml") yaml
43+
liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") yaml
4444
_doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
4545
setIgnoringRegistrationRequests False
4646
watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics
@@ -53,8 +53,8 @@ tests = testGroup "watched files"
5353
, testGroup "Changes"
5454
[
5555
testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do
56-
liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"
57-
liftIO $ writeFile (sessionDir </> "B.hs") $ unlines
56+
liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"
57+
liftIO $ atomicFileWriteString (sessionDir </> "B.hs") $ unlines
5858
["module B where"
5959
,"b :: Bool"
6060
,"b = False"]
@@ -66,7 +66,7 @@ tests = testGroup "watched files"
6666
]
6767
expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")])]
6868
-- modify B off editor
69-
liftIO $ writeFile (sessionDir </> "B.hs") $ unlines
69+
liftIO $ atomicFileWriteString (sessionDir </> "B.hs") $ unlines
7070
["module B where"
7171
,"b :: Int"
7272
,"b = 0"]
@@ -80,7 +80,7 @@ tests = testGroup "watched files"
8080
let cabalFile = "reload.cabal"
8181
cabalContent <- liftIO $ T.readFile cabalFile
8282
let fix = T.replace "build-depends: base" "build-depends: base, split"
83-
liftIO $ T.writeFile cabalFile (fix cabalContent)
83+
liftIO $ atomicFileWriteText cabalFile (fix cabalContent)
8484
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
8585
[ FileEvent (filePathToUri $ sessionDir </> cabalFile) FileChangeType_Changed ]
8686
expectDiagnostics [(hsFile, [])]

‎hls-test-utils/src/Test/Hls/FileSystem.hs‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,15 +29,20 @@ module Test.Hls.FileSystem
2929
, directProjectMulti
3030
, simpleCabalProject
3131
, simpleCabalProject'
32+
, atomicFileWriteString
33+
, atomicFileWriteStringUTF8
34+
, atomicFileWriteText
3235
) where
3336

37+
import Control.Exception (onException)
3438
import Data.Foldable (traverse_)
3539
import qualified Data.Text as T
3640
import qualified Data.Text.IO as T
3741
import Development.IDE (NormalizedFilePath)
3842
import Language.LSP.Protocol.Types (toNormalizedFilePath)
3943
import System.Directory
4044
import System.FilePath as FP
45+
import System.IO.Extra (newTempFileWithin, writeFileUTF8)
4146
import System.Process.Extra (readProcess)
4247

4348
-- ----------------------------------------------------------------------------
@@ -244,3 +249,25 @@ simpleCabalProject' :: [FileTree] -> [FileTree]
244249
simpleCabalProject' fps =
245250
[ simpleCabalCradle
246251
] <> fps
252+
253+
254+
atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO a
255+
atomicFileWrite targetPath write = do
256+
let dir = takeDirectory targetPath
257+
createDirectoryIfMissing True dir
258+
(tempFilePath, cleanUp) <- newTempFileWithin dir
259+
(write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> pure x)
260+
`onException` cleanUp
261+
262+
263+
atomicFileWriteString :: FilePath -> String -> IO ()
264+
atomicFileWriteString targetPath content =
265+
atomicFileWrite targetPath (flip writeFile content)
266+
267+
atomicFileWriteStringUTF8 :: FilePath -> String -> IO ()
268+
atomicFileWriteStringUTF8 targetPath content =
269+
atomicFileWrite targetPath (flip writeFileUTF8 content)
270+
271+
atomicFileWriteText :: FilePath -> T.Text -> IO ()
272+
atomicFileWriteText targetPath content =
273+
atomicFileWrite targetPath (flip T.writeFile content)

0 commit comments

Comments
 (0)