1module UnitTests.Distribution.Client.FileMonitor (tests) where
2
3import Distribution.Deprecated.Text (simpleParse)
4
5import Data.Proxy (Proxy (..))
6import Control.Monad
7import Control.Exception
8import Control.Concurrent (threadDelay)
9import qualified Data.Set as Set
10import System.FilePath
11import qualified System.Directory as IO
12import Prelude hiding (writeFile)
13import qualified Prelude as IO (writeFile)
14
15import Distribution.Compat.Binary
16import Distribution.Simple.Utils (withTempDirectory)
17import Distribution.Verbosity (silent)
18
19import Distribution.Client.FileMonitor
20import Distribution.Compat.Time
21import Distribution.Utils.Structured (structureHash, Structured)
22import GHC.Fingerprint (Fingerprint (..))
23
24import Test.Tasty
25import Test.Tasty.HUnit
26
27
28tests :: Int -> [TestTree]
29tests mtimeChange =
30  [ testGroup "Structured hashes"
31    [ testCase "MonitorStateFile"    $ structureHash (Proxy :: Proxy MonitorStateFile)    @?= Fingerprint 0xe4108804c34962f6 0x06e94f8fc9e48e13
32    , testCase "MonitorStateGlob"    $ structureHash (Proxy :: Proxy MonitorStateGlob)    @?= Fingerprint 0xfd8f6be0e8258fe7 0xdb5fac737139bca6
33    , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint 0xb745f4ea498389a5 0x70db6adb5078aa27
34    ]
35  , testCase "sanity check mtimes"   $ testFileMTimeSanity mtimeChange
36  , testCase "sanity check dirs"     $ testDirChangeSanity mtimeChange
37  , testCase "no monitor cache"      testNoMonitorCache
38  , testCaseSteps "corrupt monitor cache" testCorruptMonitorCache
39  , testCase "empty monitor"         testEmptyMonitor
40  , testCase "missing file"          testMissingFile
41  , testCase "change file"           $ testChangedFile mtimeChange
42  , testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange
43  , testCase "update during action"  $ testUpdateDuringAction mtimeChange
44  , testCase "remove file"           testRemoveFile
45  , testCase "non-existent file"     testNonExistentFile
46  , testCase "changed file type"     $ testChangedFileType mtimeChange
47  , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange
48
49  , testGroup "glob matches"
50    [ testCase "no change"           testGlobNoChange
51    , testCase "add match"           $ testGlobAddMatch mtimeChange
52    , testCase "remove match"        $ testGlobRemoveMatch mtimeChange
53    , testCase "change match"        $ testGlobChangeMatch mtimeChange
54
55    , testCase "add match subdir"    $ testGlobAddMatchSubdir mtimeChange
56    , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange
57    , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange
58
59    , testCase "match toplevel dir"  $ testGlobMatchTopDir mtimeChange
60    , testCase "add non-match"       $ testGlobAddNonMatch mtimeChange
61    , testCase "remove non-match"    $ testGlobRemoveNonMatch mtimeChange
62
63    , testCase "add non-match"       $ testGlobAddNonMatchSubdir mtimeChange
64    , testCase "remove non-match"    $ testGlobRemoveNonMatchSubdir mtimeChange
65
66    , testCase "invariant sorted 1"  $ testInvariantMonitorStateGlobFiles
67                                         mtimeChange
68    , testCase "invariant sorted 2"  $ testInvariantMonitorStateGlobDirs
69                                         mtimeChange
70
71    , testCase "match dirs"          $ testGlobMatchDir mtimeChange
72    , testCase "match dirs only"     $ testGlobMatchDirOnly mtimeChange
73    , testCase "change file type"    $ testGlobChangeFileType mtimeChange
74    , testCase "absolute paths"      $ testGlobAbsolutePath mtimeChange
75    ]
76
77  , testCase "value unchanged"       testValueUnchanged
78  , testCase "value changed"         testValueChanged
79  , testCase "value & file changed"  $ testValueAndFileChanged mtimeChange
80  , testCase "value updated"         testValueUpdated
81  ]
82
83-- Check the file system behaves the way we expect it to
84
85-- we rely on file mtimes having a reasonable resolution
86testFileMTimeSanity :: Int -> Assertion
87testFileMTimeSanity mtimeChange =
88  withTempDirectory silent "." "file-status-" $ \dir -> do
89    replicateM_ 10 $ do
90      IO.writeFile (dir </> "a") "content"
91      t1 <- getModTime (dir </> "a")
92      threadDelay mtimeChange
93      IO.writeFile (dir </> "a") "content"
94      t2 <- getModTime (dir </> "a")
95      assertBool "expected different file mtimes" (t2 > t1)
96
97-- We rely on directories changing mtime when entries are added or removed
98testDirChangeSanity :: Int -> Assertion
99testDirChangeSanity mtimeChange =
100  withTempDirectory silent "." "dir-mtime-" $ \dir -> do
101
102    expectMTimeChange dir "file add" $
103      IO.writeFile (dir </> "file") "content"
104
105    expectMTimeSame dir "file content change" $
106      IO.writeFile (dir </> "file") "new content"
107
108    expectMTimeChange dir "file del" $
109      IO.removeFile (dir </> "file")
110
111    expectMTimeChange dir "subdir add" $
112      IO.createDirectory (dir </> "dir")
113
114    expectMTimeSame dir "subdir file add" $
115      IO.writeFile (dir </> "dir" </> "file") "content"
116
117    expectMTimeChange dir "subdir file move in" $
118      IO.renameFile (dir </> "dir" </> "file") (dir </> "file")
119
120    expectMTimeChange dir "subdir file move out" $
121      IO.renameFile (dir </> "file") (dir </> "dir" </> "file")
122
123    expectMTimeSame dir "subdir dir add" $
124      IO.createDirectory (dir </> "dir" </> "subdir")
125
126    expectMTimeChange dir "subdir dir move in" $
127      IO.renameDirectory (dir </> "dir" </> "subdir") (dir </> "subdir")
128
129    expectMTimeChange dir "subdir dir move out" $
130      IO.renameDirectory (dir </> "subdir") (dir </> "dir" </> "subdir")
131
132  where
133    expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO ()
134                                       -> Assertion
135
136    expectMTimeChange dir descr action = do
137      t  <- getModTime dir
138      threadDelay mtimeChange
139      action
140      t' <- getModTime dir
141      assertBool ("expected dir mtime change on " ++ descr) (t' > t)
142
143    expectMTimeSame dir descr action = do
144      t  <- getModTime dir
145      threadDelay mtimeChange
146      action
147      t' <- getModTime dir
148      assertBool ("expected same dir mtime on " ++ descr) (t' == t)
149
150
151-- Now for the FileMonitor tests proper...
152
153-- first run, where we don't even call updateMonitor
154testNoMonitorCache :: Assertion
155testNoMonitorCache =
156  withFileMonitor $ \root monitor -> do
157    reason <- expectMonitorChanged root (monitor :: FileMonitor () ()) ()
158    reason @?= MonitorFirstRun
159
160-- write garbage into the binary cache file
161testCorruptMonitorCache :: (String -> IO ()) -> Assertion
162testCorruptMonitorCache step =
163  withFileMonitor $ \root monitor -> do
164    step "Writing broken file"
165    IO.writeFile (fileMonitorCacheFile monitor) "broken"
166    reason <- expectMonitorChanged root monitor ()
167    reason @?= MonitorCorruptCache
168
169    step "Updating file monitor"
170    updateMonitor root monitor [] () ()
171    (res, files) <- expectMonitorUnchanged root monitor ()
172    res   @?= ()
173    files @?= []
174
175    step "Writing broken file again"
176    IO.writeFile (fileMonitorCacheFile monitor) "broken"
177    reason2 <- expectMonitorChanged root monitor ()
178    reason2 @?= MonitorCorruptCache
179
180-- no files to monitor
181testEmptyMonitor :: Assertion
182testEmptyMonitor =
183  withFileMonitor $ \root monitor -> do
184    touchFile root "a"
185    updateMonitor root monitor [] () ()
186    touchFile root "b"
187    (res, files) <- expectMonitorUnchanged root monitor ()
188    res   @?= ()
189    files @?= []
190
191-- monitor a file that is expected to exist
192testMissingFile :: Assertion
193testMissingFile = do
194    test monitorFile       touchFile  "a"
195    test monitorFileHashed touchFile  "a"
196    test monitorFile       touchFile ("dir" </> "a")
197    test monitorFileHashed touchFile ("dir" </> "a")
198    test monitorDirectory  touchDir   "a"
199    test monitorDirectory  touchDir  ("dir" </> "a")
200  where
201    test :: (FilePath -> MonitorFilePath)
202         -> (RootPath -> FilePath -> IO ())
203         -> FilePath
204         -> IO ()
205    test monitorKind touch file =
206      withFileMonitor $ \root monitor -> do
207        -- a file that doesn't exist at snapshot time is considered to have
208        -- changed
209        updateMonitor root monitor [monitorKind file] () ()
210        reason <- expectMonitorChanged root monitor ()
211        reason @?= MonitoredFileChanged file
212
213        -- a file doesn't exist at snapshot time, but gets added afterwards is
214        -- also considered to have changed
215        updateMonitor root monitor [monitorKind file] () ()
216        touch root file
217        reason2 <- expectMonitorChanged root monitor ()
218        reason2 @?= MonitoredFileChanged file
219
220
221testChangedFile :: Int -> Assertion
222testChangedFile mtimeChange = do
223    test monitorFile       touchFile touchFile         "a"
224    test monitorFileHashed touchFile touchFileContent  "a"
225    test monitorFile       touchFile touchFile        ("dir" </> "a")
226    test monitorFileHashed touchFile touchFileContent ("dir" </> "a")
227    test monitorDirectory  touchDir  touchDir          "a"
228    test monitorDirectory  touchDir  touchDir         ("dir" </> "a")
229  where
230    test :: (FilePath -> MonitorFilePath)
231         -> (RootPath -> FilePath -> IO ())
232         -> (RootPath -> FilePath -> IO ())
233         -> FilePath
234         -> IO ()
235    test monitorKind touch touch' file =
236      withFileMonitor $ \root monitor -> do
237        touch root file
238        updateMonitor root monitor [monitorKind file] () ()
239        threadDelay mtimeChange
240        touch' root file
241        reason <- expectMonitorChanged root monitor ()
242        reason @?= MonitoredFileChanged file
243
244
245testChangedFileMtimeVsContent :: Int -> Assertion
246testChangedFileMtimeVsContent mtimeChange =
247  withFileMonitor $ \root monitor -> do
248    -- if we don't touch the file, it's unchanged
249    touchFile root "a"
250    updateMonitor root monitor [monitorFile "a"] () ()
251    (res, files) <- expectMonitorUnchanged root monitor ()
252    res   @?= ()
253    files @?= [monitorFile "a"]
254
255    -- if we do touch the file, it's changed if we only consider mtime
256    updateMonitor root monitor [monitorFile "a"] () ()
257    threadDelay mtimeChange
258    touchFile root "a"
259    reason <- expectMonitorChanged root monitor ()
260    reason @?= MonitoredFileChanged "a"
261
262    -- but if we touch the file, it's unchanged if we consider content hash
263    updateMonitor root monitor [monitorFileHashed "a"] () ()
264    threadDelay mtimeChange
265    touchFile root "a"
266    (res2, files2) <- expectMonitorUnchanged root monitor ()
267    res2   @?= ()
268    files2 @?= [monitorFileHashed "a"]
269
270    -- finally if we change the content it's changed
271    updateMonitor root monitor [monitorFileHashed "a"] () ()
272    threadDelay mtimeChange
273    touchFileContent root "a"
274    reason2 <- expectMonitorChanged root monitor ()
275    reason2 @?= MonitoredFileChanged "a"
276
277
278testUpdateDuringAction :: Int -> Assertion
279testUpdateDuringAction mtimeChange = do
280    test (monitorFile        "a") touchFile "a"
281    test (monitorFileHashed  "a") touchFile "a"
282    test (monitorDirectory   "a") touchDir  "a"
283    test (monitorFileGlobStr "*") touchFile "a"
284    test (monitorFileGlobStr "*") { monitorKindDir = DirModTime }
285                                  touchDir  "a"
286  where
287    test :: MonitorFilePath
288         -> (RootPath -> FilePath -> IO ())
289         -> FilePath
290         -> IO ()
291    test monitorSpec touch file =
292      withFileMonitor $ \root monitor -> do
293        touch root file
294        updateMonitor root monitor [monitorSpec] () ()
295
296        -- start doing an update action...
297        threadDelay mtimeChange -- some time passes
298        touch root file         -- a file gets updates during the action
299        threadDelay mtimeChange -- some time passes then we finish
300        updateMonitor root monitor [monitorSpec] () ()
301        -- we don't notice this change since we took the timestamp after the
302        -- action finished
303        (res, files) <- expectMonitorUnchanged root monitor ()
304        res   @?= ()
305        files @?= [monitorSpec]
306
307        -- Let's try again, this time taking the timestamp before the action
308        timestamp' <- beginUpdateFileMonitor
309        threadDelay mtimeChange -- some time passes
310        touch root file         -- a file gets updates during the action
311        threadDelay mtimeChange -- some time passes then we finish
312        updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () ()
313        -- now we do notice the change since we took the snapshot before the
314        -- action finished
315        reason <- expectMonitorChanged root monitor ()
316        reason @?= MonitoredFileChanged file
317
318
319testRemoveFile :: Assertion
320testRemoveFile = do
321    test monitorFile       touchFile removeFile  "a"
322    test monitorFileHashed touchFile removeFile  "a"
323    test monitorFile       touchFile removeFile ("dir" </> "a")
324    test monitorFileHashed touchFile removeFile ("dir" </> "a")
325    test monitorDirectory  touchDir  removeDir   "a"
326    test monitorDirectory  touchDir  removeDir  ("dir" </> "a")
327  where
328    test :: (FilePath -> MonitorFilePath)
329         -> (RootPath -> FilePath -> IO ())
330         -> (RootPath -> FilePath -> IO ())
331         -> FilePath
332         -> IO ()
333    test monitorKind touch remove file =
334      withFileMonitor $ \root monitor -> do
335        touch root file
336        updateMonitor root monitor [monitorKind file] () ()
337        remove root file
338        reason <- expectMonitorChanged root monitor ()
339        reason @?= MonitoredFileChanged file
340
341
342-- monitor a file that we expect not to exist
343testNonExistentFile :: Assertion
344testNonExistentFile =
345  withFileMonitor $ \root monitor -> do
346    -- a file that doesn't exist at snapshot time or check time is unchanged
347    updateMonitor root monitor [monitorNonExistentFile "a"] () ()
348    (res, files) <- expectMonitorUnchanged root monitor ()
349    res   @?= ()
350    files @?= [monitorNonExistentFile "a"]
351
352    -- if the file then exists it has changed
353    touchFile root "a"
354    reason <- expectMonitorChanged root monitor ()
355    reason @?= MonitoredFileChanged "a"
356
357    -- if the file then exists at snapshot and check time it has changed
358    updateMonitor root monitor [monitorNonExistentFile "a"] () ()
359    reason2 <- expectMonitorChanged root monitor ()
360    reason2 @?= MonitoredFileChanged "a"
361
362    -- but if the file existed at snapshot time and doesn't exist at check time
363    -- it is consider unchanged. This is unlike files we expect to exist, but
364    -- that's because files that exist can have different content and actions
365    -- can depend on that content, whereas if the action expected a file not to
366    -- exist and it now does not, it'll give the same result, irrespective of
367    -- the fact that the file might have existed in the meantime.
368    updateMonitor root monitor [monitorNonExistentFile "a"] () ()
369    removeFile root "a"
370    (res2, files2) <- expectMonitorUnchanged root monitor ()
371    res2   @?= ()
372    files2 @?= [monitorNonExistentFile "a"]
373
374
375testChangedFileType :: Int-> Assertion
376testChangedFileType mtimeChange = do
377    test (monitorFile            "a") touchFile removeFile createDir
378    test (monitorFileHashed      "a") touchFile removeFile createDir
379
380    test (monitorDirectory       "a") createDir removeDir touchFile
381    test (monitorFileOrDirectory "a") createDir removeDir touchFile
382
383    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }
384                                      touchFile removeFile createDir
385    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }
386                                      createDir removeDir touchFile
387  where
388    test :: MonitorFilePath
389         -> (RootPath -> String -> IO ())
390         -> (RootPath -> String -> IO ())
391         -> (RootPath -> String -> IO ())
392         -> IO ()
393    test monitorKind touch remove touch' =
394      withFileMonitor $ \root monitor -> do
395        touch  root "a"
396        updateMonitor root monitor [monitorKind] () ()
397        threadDelay mtimeChange
398        remove root "a"
399        touch' root "a"
400        reason <- expectMonitorChanged root monitor ()
401        reason @?= MonitoredFileChanged "a"
402
403-- Monitoring the same file with two different kinds of monitor should work
404-- both should be kept, and both checked for changes.
405-- We had a bug where only one monitor kind was kept per file.
406-- https://github.com/haskell/cabal/pull/3863#issuecomment-248495178
407testMultipleMonitorKinds :: Int -> Assertion
408testMultipleMonitorKinds mtimeChange =
409  withFileMonitor $ \root monitor -> do
410    touchFile root "a"
411    updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () ()
412    (res, files) <- expectMonitorUnchanged root monitor ()
413    res   @?= ()
414    files @?= [monitorFile "a", monitorFileHashed "a"]
415    threadDelay mtimeChange
416    touchFile root "a" -- not changing content, just mtime
417    reason <- expectMonitorChanged root monitor ()
418    reason @?= MonitoredFileChanged "a"
419
420    createDir root "dir"
421    updateMonitor root monitor [monitorDirectory "dir",
422                                monitorDirectoryExistence "dir"] () ()
423    (res2, files2) <- expectMonitorUnchanged root monitor ()
424    res2   @?= ()
425    files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"]
426    threadDelay mtimeChange
427    touchFile root ("dir" </> "a") -- changing dir mtime, not existence
428    reason2 <- expectMonitorChanged root monitor ()
429    reason2 @?= MonitoredFileChanged "dir"
430
431
432------------------
433-- globs
434--
435
436testGlobNoChange :: Assertion
437testGlobNoChange =
438  withFileMonitor $ \root monitor -> do
439    touchFile root ("dir" </> "good-a")
440    touchFile root ("dir" </> "good-b")
441    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
442    (res, files) <- expectMonitorUnchanged root monitor ()
443    res   @?= ()
444    files @?= [monitorFileGlobStr "dir/good-*"]
445
446testGlobAddMatch :: Int -> Assertion
447testGlobAddMatch mtimeChange =
448  withFileMonitor $ \root monitor -> do
449    touchFile root ("dir" </> "good-a")
450    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
451    (res, files) <- expectMonitorUnchanged root monitor ()
452    res   @?= ()
453    files @?= [monitorFileGlobStr "dir/good-*"]
454    threadDelay mtimeChange
455    touchFile root ("dir" </> "good-b")
456    reason <- expectMonitorChanged root monitor ()
457    reason @?= MonitoredFileChanged ("dir" </> "good-b")
458
459testGlobRemoveMatch :: Int -> Assertion
460testGlobRemoveMatch mtimeChange =
461  withFileMonitor $ \root monitor -> do
462    touchFile root ("dir" </> "good-a")
463    touchFile root ("dir" </> "good-b")
464    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
465    threadDelay mtimeChange
466    removeFile root "dir/good-a"
467    reason <- expectMonitorChanged root monitor ()
468    reason @?= MonitoredFileChanged ("dir" </> "good-a")
469
470testGlobChangeMatch :: Int -> Assertion
471testGlobChangeMatch mtimeChange =
472  withFileMonitor $ \root monitor -> do
473    touchFile root ("dir" </> "good-a")
474    touchFile root ("dir" </> "good-b")
475    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
476    threadDelay mtimeChange
477    touchFile root ("dir" </> "good-b")
478    (res, files) <- expectMonitorUnchanged root monitor ()
479    res   @?= ()
480    files @?= [monitorFileGlobStr "dir/good-*"]
481
482    touchFileContent root ("dir" </> "good-b")
483    reason <- expectMonitorChanged root monitor ()
484    reason @?= MonitoredFileChanged ("dir" </> "good-b")
485
486testGlobAddMatchSubdir :: Int -> Assertion
487testGlobAddMatchSubdir mtimeChange =
488  withFileMonitor $ \root monitor -> do
489    touchFile root ("dir" </> "a" </> "good-a")
490    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()
491    threadDelay mtimeChange
492    touchFile root ("dir" </> "b" </> "good-b")
493    reason <- expectMonitorChanged root monitor ()
494    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")
495
496testGlobRemoveMatchSubdir :: Int -> Assertion
497testGlobRemoveMatchSubdir mtimeChange =
498  withFileMonitor $ \root monitor -> do
499    touchFile root ("dir" </> "a" </> "good-a")
500    touchFile root ("dir" </> "b" </> "good-b")
501    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()
502    threadDelay mtimeChange
503    removeDir root ("dir" </> "a")
504    reason <- expectMonitorChanged root monitor ()
505    reason @?= MonitoredFileChanged ("dir" </> "a" </> "good-a")
506
507testGlobChangeMatchSubdir :: Int -> Assertion
508testGlobChangeMatchSubdir mtimeChange =
509  withFileMonitor $ \root monitor -> do
510    touchFile root ("dir" </> "a" </> "good-a")
511    touchFile root ("dir" </> "b" </> "good-b")
512    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()
513    threadDelay mtimeChange
514    touchFile root ("dir" </> "b" </> "good-b")
515    (res, files) <- expectMonitorUnchanged root monitor ()
516    res   @?= ()
517    files @?= [monitorFileGlobStr "dir/*/good-*"]
518
519    touchFileContent root "dir/b/good-b"
520    reason <- expectMonitorChanged root monitor ()
521    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")
522
523-- check nothing goes squiffy with matching in the top dir
524testGlobMatchTopDir :: Int -> Assertion
525testGlobMatchTopDir mtimeChange =
526  withFileMonitor $ \root monitor -> do
527    updateMonitor root monitor [monitorFileGlobStr "*"] () ()
528    threadDelay mtimeChange
529    touchFile root "a"
530    reason <- expectMonitorChanged root monitor ()
531    reason @?= MonitoredFileChanged "a"
532
533testGlobAddNonMatch :: Int -> Assertion
534testGlobAddNonMatch mtimeChange =
535  withFileMonitor $ \root monitor -> do
536    touchFile root ("dir" </> "good-a")
537    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
538    threadDelay mtimeChange
539    touchFile root ("dir" </> "bad")
540    (res, files) <- expectMonitorUnchanged root monitor ()
541    res   @?= ()
542    files @?= [monitorFileGlobStr "dir/good-*"]
543
544testGlobRemoveNonMatch :: Int -> Assertion
545testGlobRemoveNonMatch mtimeChange =
546  withFileMonitor $ \root monitor -> do
547    touchFile root ("dir" </> "good-a")
548    touchFile root ("dir" </> "bad")
549    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
550    threadDelay mtimeChange
551    removeFile root "dir/bad"
552    (res, files) <- expectMonitorUnchanged root monitor ()
553    res   @?= ()
554    files @?= [monitorFileGlobStr "dir/good-*"]
555
556testGlobAddNonMatchSubdir :: Int -> Assertion
557testGlobAddNonMatchSubdir mtimeChange =
558  withFileMonitor $ \root monitor -> do
559    touchFile root ("dir" </> "a" </> "good-a")
560    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()
561    threadDelay mtimeChange
562    touchFile root ("dir" </> "b" </> "bad")
563    (res, files) <- expectMonitorUnchanged root monitor ()
564    res   @?= ()
565    files @?= [monitorFileGlobStr "dir/*/good-*"]
566
567testGlobRemoveNonMatchSubdir :: Int -> Assertion
568testGlobRemoveNonMatchSubdir mtimeChange =
569  withFileMonitor $ \root monitor -> do
570    touchFile root ("dir" </> "a" </> "good-a")
571    touchFile root ("dir" </> "b" </> "bad")
572    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()
573    threadDelay mtimeChange
574    removeDir root ("dir" </> "b")
575    (res, files) <- expectMonitorUnchanged root monitor ()
576    res   @?= ()
577    files @?= [monitorFileGlobStr "dir/*/good-*"]
578
579
580-- try and tickle a bug that happens if we don't maintain the invariant that
581-- MonitorStateGlobFiles entries are sorted
582testInvariantMonitorStateGlobFiles :: Int -> Assertion
583testInvariantMonitorStateGlobFiles mtimeChange =
584  withFileMonitor $ \root monitor -> do
585    touchFile root ("dir" </> "a")
586    touchFile root ("dir" </> "b")
587    touchFile root ("dir" </> "c")
588    touchFile root ("dir" </> "d")
589    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()
590    threadDelay mtimeChange
591    -- so there should be no change (since we're doing content checks)
592    -- but if we can get the dir entries to appear in the wrong order
593    -- then if the sorted invariant is not maintained then we can fool
594    -- the 'probeGlobStatus' into thinking there's changes
595    removeFile root ("dir" </> "a")
596    removeFile root ("dir" </> "b")
597    removeFile root ("dir" </> "c")
598    removeFile root ("dir" </> "d")
599    touchFile root ("dir" </> "d")
600    touchFile root ("dir" </> "c")
601    touchFile root ("dir" </> "b")
602    touchFile root ("dir" </> "a")
603    (res, files) <- expectMonitorUnchanged root monitor ()
604    res   @?= ()
605    files @?= [monitorFileGlobStr "dir/*"]
606
607-- same thing for the subdirs case
608testInvariantMonitorStateGlobDirs :: Int -> Assertion
609testInvariantMonitorStateGlobDirs mtimeChange =
610  withFileMonitor $ \root monitor -> do
611    touchFile root ("dir" </> "a" </> "file")
612    touchFile root ("dir" </> "b" </> "file")
613    touchFile root ("dir" </> "c" </> "file")
614    touchFile root ("dir" </> "d" </> "file")
615    updateMonitor root monitor [monitorFileGlobStr "dir/*/file"] () ()
616    threadDelay mtimeChange
617    removeDir root ("dir" </> "a")
618    removeDir root ("dir" </> "b")
619    removeDir root ("dir" </> "c")
620    removeDir root ("dir" </> "d")
621    touchFile root ("dir" </> "d" </> "file")
622    touchFile root ("dir" </> "c" </> "file")
623    touchFile root ("dir" </> "b" </> "file")
624    touchFile root ("dir" </> "a" </> "file")
625    (res, files) <- expectMonitorUnchanged root monitor ()
626    res   @?= ()
627    files @?= [monitorFileGlobStr "dir/*/file"]
628
629-- ensure that a glob can match a directory as well as a file
630testGlobMatchDir :: Int -> Assertion
631testGlobMatchDir mtimeChange =
632  withFileMonitor $ \root monitor -> do
633    createDir root ("dir" </> "a")
634    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()
635    threadDelay mtimeChange
636    -- nothing changed yet
637    (res, files) <- expectMonitorUnchanged root monitor ()
638    res   @?= ()
639    files @?= [monitorFileGlobStr "dir/*"]
640    -- expect dir/b to match and be detected as changed
641    createDir root ("dir" </> "b")
642    reason <- expectMonitorChanged root monitor ()
643    reason @?= MonitoredFileChanged ("dir" </> "b")
644    -- now remove dir/a and expect it to be detected as changed
645    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()
646    threadDelay mtimeChange
647    removeDir root ("dir" </> "a")
648    reason2 <- expectMonitorChanged root monitor ()
649    reason2 @?= MonitoredFileChanged ("dir" </> "a")
650
651testGlobMatchDirOnly :: Int -> Assertion
652testGlobMatchDirOnly mtimeChange =
653  withFileMonitor $ \root monitor -> do
654    updateMonitor root monitor [monitorFileGlobStr "dir/*/"] () ()
655    threadDelay mtimeChange
656    -- expect file dir/a to not match, so not detected as changed
657    touchFile root ("dir" </> "a")
658    (res, files) <- expectMonitorUnchanged root monitor ()
659    res   @?= ()
660    files @?= [monitorFileGlobStr "dir/*/"]
661    -- note that checking the file monitor for changes can updates the
662    -- cached dir mtimes (when it has to record that there's new matches)
663    -- so we need an extra mtime delay
664    threadDelay mtimeChange
665    -- but expect dir/b to match
666    createDir root ("dir" </> "b")
667    reason <- expectMonitorChanged root monitor ()
668    reason @?= MonitoredFileChanged ("dir" </> "b")
669
670testGlobChangeFileType :: Int -> Assertion
671testGlobChangeFileType mtimeChange =
672  withFileMonitor $ \root monitor -> do
673    -- change file to dir
674    touchFile root ("dir" </> "a")
675    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()
676    threadDelay mtimeChange
677    removeFile root ("dir" </> "a")
678    createDir  root ("dir" </> "a")
679    reason <- expectMonitorChanged root monitor ()
680    reason @?= MonitoredFileChanged ("dir" </> "a")
681    -- change dir to file
682    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()
683    threadDelay mtimeChange
684    removeDir root ("dir" </> "a")
685    touchFile root ("dir" </> "a")
686    reason2 <- expectMonitorChanged root monitor ()
687    reason2 @?= MonitoredFileChanged ("dir" </> "a")
688
689testGlobAbsolutePath :: Int -> Assertion
690testGlobAbsolutePath mtimeChange =
691  withFileMonitor $ \root monitor -> do
692    root' <- absoluteRoot root
693    -- absolute glob, removing a file
694    touchFile root ("dir/good-a")
695    touchFile root ("dir/good-b")
696    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()
697    threadDelay mtimeChange
698    removeFile root "dir/good-a"
699    reason <- expectMonitorChanged root monitor ()
700    reason @?= MonitoredFileChanged (root' </> "dir/good-a")
701    -- absolute glob, adding a file
702    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()
703    threadDelay mtimeChange
704    touchFile root ("dir/good-a")
705    reason2 <- expectMonitorChanged root monitor ()
706    reason2 @?= MonitoredFileChanged (root' </> "dir/good-a")
707    -- absolute glob, changing a file
708    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()
709    threadDelay mtimeChange
710    touchFileContent root "dir/good-b"
711    reason3 <- expectMonitorChanged root monitor ()
712    reason3 @?= MonitoredFileChanged (root' </> "dir/good-b")
713
714
715------------------
716-- value changes
717--
718
719testValueUnchanged :: Assertion
720testValueUnchanged =
721  withFileMonitor $ \root monitor -> do
722    touchFile root "a"
723    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"
724    (res, files) <- expectMonitorUnchanged root monitor 42
725    res   @?= "ok"
726    files @?= [monitorFile "a"]
727
728testValueChanged :: Assertion
729testValueChanged =
730  withFileMonitor $ \root monitor -> do
731    touchFile root "a"
732    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"
733    reason <- expectMonitorChanged root monitor 43
734    reason @?= MonitoredValueChanged 42
735
736testValueAndFileChanged :: Int -> Assertion
737testValueAndFileChanged mtimeChange =
738  withFileMonitor $ \root monitor -> do
739    touchFile root "a"
740
741    -- we change the value and the file, and the value change is reported
742    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"
743    threadDelay mtimeChange
744    touchFile root "a"
745    reason <- expectMonitorChanged root monitor 43
746    reason @?= MonitoredValueChanged 42
747
748    -- if fileMonitorCheckIfOnlyValueChanged then if only the value changed
749    -- then it's reported as MonitoredValueChanged
750    let monitor' :: FileMonitor Int String
751        monitor' = monitor { fileMonitorCheckIfOnlyValueChanged = True }
752    updateMonitor root monitor' [monitorFile "a"] 42 "ok"
753    reason2 <- expectMonitorChanged root monitor' 43
754    reason2 @?= MonitoredValueChanged 42
755
756    -- but if a file changed too then we don't report MonitoredValueChanged
757    updateMonitor root monitor' [monitorFile "a"] 42 "ok"
758    threadDelay mtimeChange
759    touchFile root "a"
760    reason3 <- expectMonitorChanged root monitor' 43
761    reason3 @?= MonitoredFileChanged "a"
762
763testValueUpdated :: Assertion
764testValueUpdated =
765  withFileMonitor $ \root monitor -> do
766    touchFile root "a"
767
768    let monitor' :: FileMonitor (Set.Set Int) String
769        monitor' = (monitor :: FileMonitor (Set.Set Int) String) {
770                     fileMonitorCheckIfOnlyValueChanged = True,
771                     fileMonitorKeyValid = Set.isSubsetOf
772                   }
773
774    updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42,43]) "ok"
775    (res,_files) <- expectMonitorUnchanged root monitor' (Set.fromList [42])
776    res @?= "ok"
777
778    reason <- expectMonitorChanged root monitor' (Set.fromList [42,44])
779    reason @?= MonitoredValueChanged (Set.fromList [42,43])
780
781
782-------------
783-- Utils
784
785newtype RootPath = RootPath FilePath
786
787touchFile :: RootPath -> FilePath -> IO ()
788touchFile (RootPath root) fname = do
789  let path = root </> fname
790  IO.createDirectoryIfMissing True (takeDirectory path)
791  IO.writeFile path "touched"
792
793touchFileContent :: RootPath -> FilePath -> IO ()
794touchFileContent (RootPath root) fname = do
795  let path = root </> fname
796  IO.createDirectoryIfMissing True (takeDirectory path)
797  IO.writeFile path "different"
798
799removeFile :: RootPath -> FilePath -> IO ()
800removeFile (RootPath root) fname = IO.removeFile (root </> fname)
801
802touchDir :: RootPath -> FilePath -> IO ()
803touchDir root@(RootPath rootdir) dname = do
804  IO.createDirectoryIfMissing True (rootdir </> dname)
805  touchFile  root (dname </> "touch")
806  removeFile root (dname </> "touch")
807
808createDir :: RootPath -> FilePath -> IO ()
809createDir (RootPath root) dname = do
810  let path = root </> dname
811  IO.createDirectoryIfMissing True (takeDirectory path)
812  IO.createDirectory path
813
814removeDir :: RootPath -> FilePath -> IO ()
815removeDir (RootPath root) dname = IO.removeDirectoryRecursive (root </> dname)
816
817absoluteRoot :: RootPath -> IO FilePath
818absoluteRoot (RootPath root) = IO.canonicalizePath root
819
820monitorFileGlobStr :: String -> MonitorFilePath
821monitorFileGlobStr globstr
822  | Just glob <- simpleParse globstr = monitorFileGlob glob
823  | otherwise                        = error $ "Failed to parse " ++ globstr
824
825
826expectMonitorChanged :: (Binary a, Structured a, Binary b, Structured b)
827                     => RootPath -> FileMonitor a b -> a
828                     -> IO (MonitorChangedReason a)
829expectMonitorChanged root monitor key = do
830  res <- checkChanged root monitor key
831  case res of
832    MonitorChanged reason -> return reason
833    MonitorUnchanged _ _  -> throwIO $ HUnitFailure Nothing "expected change"
834
835expectMonitorUnchanged :: (Binary a, Structured a, Binary b, Structured b)
836                        => RootPath -> FileMonitor a b -> a
837                        -> IO (b, [MonitorFilePath])
838expectMonitorUnchanged root monitor key = do
839  res <- checkChanged root monitor key
840  case res of
841    MonitorChanged _reason   -> throwIO $ HUnitFailure Nothing "expected no change"
842    MonitorUnchanged b files -> return (b, files)
843
844checkChanged :: (Binary a, Structured a, Binary b, Structured b)
845             => RootPath -> FileMonitor a b
846             -> a -> IO (MonitorChanged a b)
847checkChanged (RootPath root) monitor key =
848  checkFileMonitorChanged monitor root key
849
850updateMonitor :: (Binary a, Structured a, Binary b, Structured b)
851              => RootPath -> FileMonitor a b
852              -> [MonitorFilePath] -> a -> b -> IO ()
853updateMonitor (RootPath root) monitor files key result =
854  updateFileMonitor monitor root Nothing files key result
855
856updateMonitorWithTimestamp :: (Binary a, Structured a, Binary b, Structured b)
857              => RootPath -> FileMonitor a b -> MonitorTimestamp
858              -> [MonitorFilePath] -> a -> b -> IO ()
859updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result =
860  updateFileMonitor monitor root (Just timestamp) files key result
861
862withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c
863withFileMonitor action = do
864  withTempDirectory silent "." "file-status-" $ \root -> do
865    let file    = root <.> "monitor"
866        monitor = newFileMonitor file
867    finally (action (RootPath root) monitor) $ do
868      exists <- IO.doesFileExist file
869      when exists $ IO.removeFile file
870