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