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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module FSNotify.Test.Util where
import Control.Exception.Safe (Handler(..))
import Control.Monad.Logger
import Control.Retry
import Data.String.Interpolate
import System.FSNotify
import System.FilePath
import Test.Sandwich
import UnliftIO hiding (poll, Handler)
import UnliftIO.Concurrent
import UnliftIO.Directory
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
#ifdef mingw32_HOST_OS
import Data.Bits
import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY)
import System.Win32.SymbolicLink (createSymbolicLinkFile)
-- Perturb the file's attributes, to check that a modification event is emitted
changeFileAttributes :: FilePath -> IO ()
changeFileAttributes file = do
attrs <- getFileAttributes file
setFileAttributes file (attrs `xor` fILE_ATTRIBUTE_TEMPORARY)
createSymLink :: FilePath -> FilePath -> IO ()
#if __GLASGOW_HASKELL__ < 900
createSymLink file1 file2 = createSymbolicLinkFile file1 file2
#else
createSymLink file1 file2 = createSymbolicLinkFile file1 file2 True
#endif
#else
import System.PosixCompat.Files (touchFile, createSymbolicLink)
changeFileAttributes :: FilePath -> IO ()
changeFileAttributes = touchFile
createSymLink :: FilePath -> FilePath -> IO ()
createSymLink = createSymbolicLink
#endif
isMac :: Bool
#ifdef darwin_HOST_OS
isMac = True
#else
isMac = False
#endif
isWin :: Bool
#ifdef mingw32_HOST_OS
isWin = True
#else
isWin = False
#endif
isLinux :: Bool
#ifdef linux_HOST_OS
isLinux = True
#else
isLinux = False
#endif
isFreeBSD :: Bool
#ifdef freebsd_HOST_OS
isFreeBSD = True
#else
isFreeBSD = False
#endif
haveNativeWatcher :: Bool
#ifdef HAVE_NATIVE_WATCHER
haveNativeWatcher = True
#else
haveNativeWatcher = False
#endif
waitUntil :: MonadUnliftIO m => Double -> m a -> m a
#if MIN_VERSION_retry(0, 7, 0)
waitUntil timeInSeconds action = withRunInIO $ \runInIO ->
recovering policy [\_ -> Handler handleFn] (\_ -> runInIO action)
#else
waitUntil timeInSeconds action = withRunInIO $ \runInIO ->
recovering policy [\_ -> Handler handleFn] (runInIO action)
#endif
where
handleFn :: SomeException -> IO Bool
handleFn (fromException -> Just (_ :: FailureReason)) = return True
handleFn _ = return False
policy = limitRetriesByCumulativeDelay (round (timeInSeconds * 1000000.0)) $ capDelay 1000000 $ exponentialBackoff 1000
data TestFolderContext = TestFolderContext {
watchedDir :: FilePath
, filePath :: FilePath
, getEvents :: IO [Event]
, clearEvents :: IO ()
}
data TestFolderGenerator = TestFolderGenerator {
testFolderGeneratorRootDir :: FilePath
, testFolderGeneratorId :: MVar Int
}
newTestFolderGenerator :: MonadUnliftIO m => FilePath -> m TestFolderGenerator
newTestFolderGenerator dir = TestFolderGenerator dir <$> newMVar 0
withTestFolderGenerator :: MonadUnliftIO m => (TestFolderGenerator -> m a) -> m a
withTestFolderGenerator action = do
withSystemTempDirectory "hfsnotify-tests" $ \dir ->
newTestFolderGenerator dir >>= action
withRandomTempDirectory :: MonadUnliftIO m => TestFolderGenerator -> (FilePath -> m a) -> m a
withRandomTempDirectory (TestFolderGenerator {..}) action = do
testId <- modifyMVar testFolderGeneratorId $ \x ->
return (x + 1, x)
let dir = testFolderGeneratorRootDir </> ("test_" <> show testId)
bracket_ (createDirectory dir)
(removePathForcibly dir)
(action dir)
withTestFolder :: (
MonadUnliftIO m, MonadLogger m
)
=> TestFolderGenerator
-> ThreadingMode
-> Bool
-> Bool
-> Bool
-> (FilePath -> m b)
-> (b -> TestFolderContext -> m a)
-> m a
withTestFolder testFolderGenerator threadingMode poll recursive nested setup action = do
withRandomTempDirectory testFolderGenerator $ \watchedDir' -> do
info [i|Got temp directory: #{watchedDir'}|]
let fileName = "testfile"
let baseDir = if nested then watchedDir' </> "subdir" else watchedDir'
let watchFn = if recursive then watchTree else watchDir
createDirectoryIfMissing True baseDir
let p = normalise $ baseDir </> fileName
setupResult <- setup p
let pollInterval = 2 * 10^(5 :: Int)
-- Delay before starting the watcher to make sure setup events picked up.
--
-- For MacOS, we can apparently get an event for the creation of "subdir" when doing nested tests,
-- even though we create the watcher after this.
--
-- On Windows, we occasionally see a test flake when there's no pause here.
--
-- So, let's put a healthy sleep between the setup actions and the watcher initialization.
--
-- When polling, we want to ensure we wait at least as long as the effective filesystem modification
-- time granularity (which on Linux can be on the order of 10 milliseconds), *or*
-- the poll interval, whichever is greater.
threadDelay (max 5_000_000 (3 * pollInterval))
let conf = defaultConfig {
#ifndef HAVE_NATIVE_WATCHER
confWatchMode = if poll then WatchModePoll pollInterval else error "No native watcher available."
#else
confWatchMode = if poll then WatchModePoll pollInterval else WatchModeOS
#endif
, confThreadingMode = threadingMode
}
withRunInIO $ \runInIO ->
withManagerConf conf $ \mgr -> do
eventsVar <- newIORef []
bracket
(watchFn mgr watchedDir' (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ()))))
(\stop -> stop)
(\_ -> runInIO $ action setupResult $ TestFolderContext {
watchedDir = watchedDir'
, filePath = p
, getEvents = readIORef eventsVar
, clearEvents = atomicWriteIORef eventsVar []
}
)
parallelWithoutDirectory :: SpecFree context m () -> SpecFree context m ()
parallelWithoutDirectory = parallel' (defaultNodeOptions {
nodeOptionsCreateFolder = False
, nodeOptionsVisibilityThreshold = 70
})
|
