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

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