1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant multi-way if" #-}
module FSNotify.Test.EventTests where
import Control.Exception.Safe (MonadThrow)
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.List as L
import Data.Monoid
import Data.Ord (comparing)
import FSNotify.Test.Util
import Prelude hiding (FilePath)
import System.FSNotify
import System.FilePath
import System.IO (hPutStr)
import Test.Sandwich
import UnliftIO hiding (poll)
import UnliftIO.Directory
eventTests :: (
MonadUnliftIO m, MonadThrow m
) => TestFolderGenerator -> ThreadingMode -> SpecFree context m ()
eventTests testFolderGenerator threadingMode = describe "Tests" $ parallelWithoutDirectory $ do
let pollOptions = if haveNativeWatcher then [False, True] else [True]
forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallelWithoutDirectory $ do
forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $ parallelWithoutDirectory $
forM_ [False, True] $ \nested -> describe (if nested then "Nested" else "Non-nested") $ parallelWithoutDirectory $
eventTests' testFolderGenerator threadingMode poll recursive nested
eventTests' :: (
MonadUnliftIO m, MonadThrow m
) => TestFolderGenerator -> ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m ()
eventTests' testFolderGenerator threadingMode poll recursive nested = do
let withFolder' = withTestFolder testFolderGenerator threadingMode poll recursive nested
let withFolder action = withFolder' (const $ return ()) (\() ctx -> action ctx)
let waitForEvents getEvents action = waitUntil 5.0 (liftIO getEvents >>= action)
unless (nested || poll || isMac || isWin) $ it "deletes the watched directory" $ withFolder $ \(TestFolderContext watchedDir _f getEvents _clearEvents) -> do
removeDirectory watchedDir
waitForEvents getEvents $ \case
[WatchedDirectoryRemoved {..}] | eventPath `equalFilePath` watchedDir && eventIsDirectory == IsDirectory -> return ()
events -> expectationFailure $ "Got wrong events: " <> show events
it "works with a new file" $ withFolder $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do
let wrapper action = if | isWin -> liftIO (writeFile f "foo") >> action
| otherwise -> withFile f AppendMode $ \_ -> action
wrapper $
waitForEvents getEvents $ \events ->
if | nested && not recursive -> events `shouldBe` []
| isWin && not poll -> case events of
-- On Windows, we sometimes get an extra modified event
(sortEvents -> [Added {..}, Modified {}]) | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
| otherwise -> case events of
[Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
it "works with a new directory" $ withFolder $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do
createDirectory f
waitForEvents getEvents $ \events ->
if | nested && not recursive -> events `shouldBe` []
| otherwise -> case events of
[Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
it "works with a deleted file" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
removeFile f
waitForEvents getEvents $ \events ->
if | nested && not recursive -> events `shouldBe` []
| otherwise -> case events of
[Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
unless isWin $ do
it "works if there is bad symlink" $ withFolder' (\f -> liftIO $ createSymLink (f <> ".doesNotExist") f) $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
waitForEvents getEvents $ \events -> events `shouldBe` []
it "works with a deleted directory" $ withFolder' (\f -> liftIO $ createDirectory f) $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
removeDirectory f
waitForEvents getEvents $ \events ->
if | nested && not recursive -> events `shouldBe` []
| otherwise -> case events of
[Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
it "works with modified file attributes" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
liftIO $ changeFileAttributes f
-- This test is disabled when polling because the PollManager only keeps track of
-- modification time, so it won't catch an unrelated file attribute change
waitForEvents getEvents $ \events ->
if | poll -> return ()
| nested && not recursive -> events `shouldBe` []
| isWin -> case events of
[Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
| otherwise -> case events of
[ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
it "works with a modified file" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
(if isWin then withSingleWriteFile f "foo" else withOpenWritableAndWrite f "foo") $
waitForEvents getEvents $ \events ->
if | nested && not recursive -> events `shouldBe` []
| isMac || isFreeBSD -> case events of
[Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
[ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"
| otherwise -> case events of
[Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"
when (isLinux || isFreeBSD) $ unless poll $ do
let setup f = liftIO $ do
h <- openFile f WriteMode
hPutStr h "asdf" >> hFlush h
return h
it "gets a close_write" $ withFolder' setup $ \h (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
liftIO $ hClose h
waitForEvents getEvents $ \events ->
if | nested && not recursive -> events `shouldBe` []
| otherwise -> case events of
[CloseWrite {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
_ -> expectationFailure $ "Got wrong events: " <> show events
withSingleWriteFile :: MonadIO m => FilePath -> String -> m b -> m b
withSingleWriteFile fp contents action = do
liftIO $ writeFile fp contents
action
withOpenWritableAndWrite :: MonadUnliftIO m => FilePath -> String -> m b -> m b
withOpenWritableAndWrite fp contents action = do
withFile fp WriteMode $ \h ->
flip finally (hClose h) $ do
liftIO $ hPutStr h contents
action
sortEvents :: [Event] -> [Event]
sortEvents = L.sortBy (comparing eventToNum)
where
eventToNum :: Event -> Int
eventToNum (Added {}) = 1
eventToNum (Modified {}) = 2
eventToNum (ModifiedAttributes {}) = 3
eventToNum (Removed {}) = 4
eventToNum (WatchedDirectoryRemoved {}) = 5
eventToNum (CloseWrite {}) = 6
eventToNum (Unknown {}) = 7
|
