test/Streamly/Test/FileSystem/Event/Common.hs · streamly

git.iko.soy/streamly

on a05abfc help sign in

streamly/test/Streamly/Test/FileSystem/Event/Common.hs

418 lines 14 kB history raw

1-- |

2-- Module : Streamly.Test.FileSystem.Event.Common

4-- License : BSD-3-Clause

5-- Maintainer : streamly@composewell.com

6-- Stability : experimental

7-- Portability : GHC

8--

9module Streamly.Test.FileSystem.Event.Common

10 ( TestDesc

12 -- * Running tests

13 , runTests

14 , WatchRootType (..)

16 -- * Event predicates

17 , dirEvent

18 , fileEvent

20 -- * Tests

21 , dirCreate

22 , dirCreateWithParent

23 , dirDelete

24 , dirMove

25 , rootDirMove

27 , fileCreate

28 , fileCreateWithParent

29 , fileDelete

30 , fileModify

31 , fileMove

32 , rootFileMove

34 , commonTests

35 , commonRecTests

36 )

38where

40import Debug.Trace (trace)

41import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)

42import Control.Monad (when)

43import Control.Monad.IO.Class (MonadIO)

44import Data.Bifunctor (first)

45import Data.Function ((&))

46import Data.Functor.Identity (runIdentity)

47import Data.List.NonEmpty (NonEmpty)

48import Data.Word (Word8)

49import Streamly.Data.Array.Foreign (Array)

50import System.Directory

51 ( createDirectory

52 , createDirectoryIfMissing

53 , createDirectoryLink

54 , removeFile

55 , removePathForcibly

56 , renameDirectory

57 , renamePath

58 )

59import System.FilePath ((</>), takeDirectory)

60import System.IO

61 ( BufferMode(..), hSetBuffering, stdout, IOMode (WriteMode), openFile

62 , hClose)

63import System.IO.Temp (withSystemTempDirectory)

65import qualified Data.List.NonEmpty as NonEmpty

66import qualified Streamly.Internal.Data.Array.Foreign as Array

67import qualified Streamly.Internal.Data.Stream.IsStream as Stream

68import qualified Streamly.Unicode.Stream as Unicode

70#if defined(FILESYSTEM_EVENT_LINUX)

71import Streamly.Internal.FileSystem.Event.Linux (Event)

72import qualified Streamly.Internal.FileSystem.Event.Linux as Event

73#elif defined(FILESYSTEM_EVENT_DARWIN)

74import Streamly.Internal.FileSystem.Event.Darwin (Event)

75import qualified Streamly.Internal.FileSystem.Event.Darwin as Event

76#elif defined(FILESYSTEM_EVENT_WINDOWS)

77import Streamly.Internal.FileSystem.Event.Windows (Event)

78import qualified Streamly.Internal.FileSystem.Event.Windows as Event

79#else

80import Streamly.Internal.FileSystem.Event (Event)

81import qualified Streamly.Internal.FileSystem.Event as Event

82#endif

84import Test.Hspec

86-------------------------------------------------------------------------------

87-- Check generated events

88-------------------------------------------------------------------------------

90type EventChecker =

91 FilePath -- watch root

92 -> FilePath -- watch target, target dir if root is a symlink

93 -> MVar () -- mvar to sync file system ops and the watch

94 -> [(String, Event -> Bool)] -- expected events

95 -> IO ()

96type EventWatcher = NonEmpty (Array Word8) -> Stream.SerialT IO Event.Event

98eventMatches :: Event -> (String, Event -> Bool) -> Bool

99eventMatches ev (expectedPath, f) =

100 trace ("paths: " ++ show evPath ++ " " ++ show expectedPath)

101 (evPath == expectedPath && f ev)

102

103 where

104

105 utf8ToString :: Array Word8 -> String

106 utf8ToString =

107 runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.toStream

108

109 evPath = utf8ToString (Event.getAbsPath ev)

110

111toUtf8 :: MonadIO m => String -> m (Array Word8)

112toUtf8 = Array.fromStream . Unicode.encodeUtf8' . Stream.fromList

113

114checkEvents :: EventWatcher -> EventChecker

115checkEvents watcher rootPath targetPath mvar matchList = do

116 putStrLn ("Watching on root [" <> rootPath

117 <> "] for [" <> targetPath <> "]")

118

119 let matchList1 = fmap (first (targetPath </>)) matchList

120 finder xs ev = filter (not . eventMatches ev) xs

121

122 paths <- mapM toUtf8 [rootPath]

123 watcher (NonEmpty.fromList paths)

124 & Stream.before (putMVar mvar ())

125 & Stream.trace (putStrLn . Event.showEvent)

126 & Stream.scanl' finder matchList1

127 & Stream.takeWhile (not . null)

128 & Stream.drain

129

130-------------------------------------------------------------------------------

131-- Run tests

132-------------------------------------------------------------------------------

133

134type TestDesc =

135 ( String -- test description

136 , FilePath -> IO () -- pre test operation, arg is path of the watch root.

137 , FilePath -> IO () -- file system action, arg is path of the watch root.

138 , [(String, Event -> Bool)] -- expected events (Absolute Path, predicate)

139 )

140

141-- | Whether watch root is a symlink and if so then what's the behavior

142data WatchRootType =

143 DirType -- watch root is a directory

144 | FileType -- watch root is a file

145 | SymLinkResolvedPath -- symlink to a directory,

146 -- Event contains path via the resolved dir

147 | SymLinkOrigPath -- symlink to a directory,

148 -- Event contains path via the original symlink

149 deriving Show

150

151driver :: EventChecker -> WatchRootType -> TestDesc -> SpecWith ()

152driver checker symlinkStyle (desc, pre, ops, expected) =

153 it desc $ runOneTest `shouldReturn` ()

154

155 where

156

157 fseventDir :: String

158 fseventDir = "fsevent_dir"

159

160 runOneTest = do

161 sync <- newEmptyMVar

162 withSystemTempDirectory fseventDir $ \fp -> do

163 let root = fp </> "watch-root"

164 target <-

165 case symlinkStyle of

166 DirType -> do

167 createDirectory root

168 return root

169 FileType -> do

170 openFile root WriteMode >>= hClose

171 return root

172 SymLinkResolvedPath -> do

173 let tgt = fp </> "watch-root-real"

174 createDirectory tgt

175 createDirectoryLink tgt root

176 return tgt

177 SymLinkOrigPath -> do

178 let tgt = fp </> "watch-root-real"

179 createDirectory tgt

180 createDirectoryLink tgt root

181 return root

182

183 -- XXX On macOS we seem to get the watch root create events

184 -- even though they occur before the watch is started. Even if

185 -- we add a delay here.

186 startWatchAndCheck root target sync

187

188 startWatchAndCheck root target sync = do

189 pre root

190 -- XXX On macOS the events from pre ops also seem to be bundled

191 -- with the events occurred after the watch is started.

192 let check = checker root target sync expected

193 fsOps = Stream.fromEffect $ runFSOps root sync

194 Stream.drain $ Stream.fromEffect check `Stream.parallelFst` fsOps

195

196 runFSOps fp sync = do

197 -- We put the MVar before the event watcher starts to run but that does

198 -- not ensure that the event watcher has actually started. So we need a

199 -- delay as well. Do we?

200 takeMVar sync >> threadDelay 200000

201 ops fp

202 threadDelay 10000000

203 error "Time out occurred before event watcher could terminate"

204

205-------------------------------------------------------------------------------

206-- Test descriptions

207-------------------------------------------------------------------------------

208

209dirEvent, fileEvent :: (Event -> Bool) -> Event -> Bool

210

211#if defined(FILESYSTEM_EVENT_DARWIN)

212dirEvent f ev = Event.isDir ev && f ev

213fileEvent f ev = Event.isFile ev && f ev

214#elif defined(FILESYSTEM_EVENT_LINUX)

215dirEvent f ev = Event.isDir ev && f ev

216fileEvent f ev = not (Event.isDir ev) && f ev

217#else

218dirEvent = id

219fileEvent = id

220#endif

221

222-- XXX Tests for root as a regular file instead of dir?

223-- XXX Add symlink and hardlink tests

224-- XXX Add exception condition tests

225

226-------------------------------------------------------------------------------

227-- Dir tests

228-------------------------------------------------------------------------------

229

230createParent :: FilePath -> FilePath -> IO ()

231createParent file parent = do

232 createDirectoryIfMissing True (parent </> takeDirectory file)

233

234createDirWithParent :: FilePath -> FilePath -> IO ()

235createDirWithParent dir parent =

236 when (not (null dir)) $ createDirectoryIfMissing True (parent </> dir)

237

238createDir :: FilePath -> FilePath -> IO ()

239createDir dir parent =

240 when (not (null dir)) $ createDirectory (parent </> dir)

241

242-- | Create the dir along with its parent dir during the test. This is

243-- especially useful to detect a race in Linux case where the watch for a

244-- directory is added in event processing, so if the the child directory is

245-- created before the watch was installed then we may miss some events.

246dirCreateWithParent ::

247 String -> (String -> [([Char], Event -> Bool)]) -> TestDesc

248dirCreateWithParent dir events =

249 ( "dir created (" ++ dir ++ ")"

250 , const (return ())

251 , createDirWithParent dir

252 , events dir

253 )

254

255dirCreate :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc

256dirCreate dir events =

257 ( "dir created (" ++ dir ++ ")"

258 , createParent dir

259 , createDir dir

260 , events dir

261 )

262

263dirDelete :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc

264dirDelete dir events =

265 ( "dir deleted (" ++ dir ++ ")"

266 , createDirWithParent dir

267 , \fp -> removePathForcibly (fp </> dir)

268 , events dir

269 )

270

271dirMove ::

272 String

273 -> String

274 -> (String -> String -> [(String, Event -> Bool)])

275 -> TestDesc

276dirMove dir1 dir2 events =

277 ( "dir moved (" ++ dir1 ++ " " ++ dir2 ++ ")"

278 , createDirWithParent dir1

279 , \fp -> renameDirectory (fp </> dir1) (fp </> dir2)

280 , events dir1 dir2

281 )

282

283rootDirMove ::

284 String

285 -> (String -> [(String, Event -> Bool)])

286 -> TestDesc

287rootDirMove suffix events =

288 ( "root dir moved" ++ "(" ++ suffix ++ ")"

289 , const (return ())

290 , \fp -> renameDirectory fp (fp <> suffix)

291 , events ""

292 )

293

294-------------------------------------------------------------------------------

295-- File tests

296-------------------------------------------------------------------------------

297

298createFileWithParent :: FilePath -> FilePath -> IO ()

299createFileWithParent file parent = do

300 when (not (null file)) $

301 createDirectoryIfMissing True (parent </> takeDirectory file)

302 openFile (parent </> file) WriteMode >>= hClose

303

304createFile :: FilePath -> FilePath -> IO ()

305createFile file parent =

306 openFile (parent </> file) WriteMode >>= hClose

307

308fileCreate :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc

309fileCreate file1 events =

310 ( "File created (" ++ file1 ++ ")"

311 , createParent file1

312 , createFile file1

313 , (file1, fileEvent Event.isCreated) : events file1

314 )

315

316-- | See comments in dirCreateWithParent

317fileCreateWithParent ::

318 String -> (String -> [(String, Event -> Bool)]) -> TestDesc

319fileCreateWithParent file1 events =

320 ( "File created (" ++ file1 ++ ")"

321 , const (return ())

322 , createFileWithParent file1

323 , (file1, fileEvent Event.isCreated) : events file1

324 )

325

326fileDelete :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc

327fileDelete file1 events =

328 ( "File deleted (" ++ file1 ++ ")"

329 , createFileWithParent file1

330 , \fp -> removeFile (fp </> file1)

331 , events file1

332 )

333

334fileModify :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc

335fileModify file1 events =

336 ( "File modified (" ++ file1 ++ ")"

337 , createFileWithParent file1

338 , \fp -> writeFile (fp </> file1) "Test Data"

339 , (file1, fileEvent Event.isModified) : events file1

340 )

341

342fileMove ::

343 String

344 -> String

345 -> (String -> String -> [(String, Event -> Bool)])

346 -> TestDesc

347fileMove file1 file2 events =

348 ( "File moved (" ++ file1 ++ " " ++ file2 ++ ")"

349 , createFileWithParent file1

350 , \fp -> renamePath (fp </> file1) (fp </> file2)

351 , (file1, fileEvent Event.isMoved)

352 : (file2, fileEvent Event.isMoved)

353 : events file1 file2

354 )

355

356rootFileMove :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc

357rootFileMove suffix events =

358 ( "File moved (" ++ suffix ++ ")"

359 , const (return ())

360 , \fp -> renamePath fp (fp <> suffix)

361 , events ""

362 )

363

364-------------------------------------------------------------------------------

365-- Common test bundles

366-------------------------------------------------------------------------------

367

368withParent :: [Char] -> [Char] -> [Char]

369withParent parent file = if null parent then file else parent </> file

370

371testsWithParent :: String -> [TestDesc]

372testsWithParent p =

373 [ dirCreate

374 (withParent p "dir") (\dir -> [(dir, dirEvent Event.isCreated)])

375 , dirDelete

376 (withParent p "dir") (\dir -> [(dir, dirEvent Event.isDeleted)])

377 , dirMove

378 (withParent p "dir1")

379 (withParent p "dir2")

380 (\dir1 dir2 ->

381 [ (dir1, dirEvent Event.isMoved)

382 , (dir2, dirEvent Event.isMoved)

383 ]

384 )

385 , fileCreate (withParent p "file1") (const [])

386 , fileDelete

387 (withParent p "file1")

388 (\file -> [(file, fileEvent Event.isDeleted)])

389 , fileModify (withParent p "file1") (const [])

390 , fileMove (withParent p "file1") (withParent p "file2") (\_ _ -> [])

391 ]

392

393commonTests :: [TestDesc]

394commonTests = testsWithParent ""

395

396commonRecTests :: [TestDesc]

397commonRecTests = testsWithParent "subdir"

398

399-------------------------------------------------------------------------------

400-- Running tests

401-------------------------------------------------------------------------------

402

403runTests ::

404 String

405 -> String

406 -> EventWatcher

407 -> WatchRootType

408 -> [TestDesc]

409 -> IO ()

410runTests modName watchType watcher rootType tests = do

411 hSetBuffering stdout NoBuffering

412 hspec

413 $ describe modName

414 $ describe watchType

415 $ do

416 let checker = checkEvents watcher

417 describe ("Root type " ++ show rootType)

418 $ mapM_ (driver checker rootType) tests