cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs

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