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

git.iko.soy/streamly

on 666eb07 help sign in

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

420 lines 14 kB history raw

1{-# OPTIONS_GHC -Wno-deprecations #-}

3-- |

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

6-- License : BSD-3-Clause

7-- Maintainer : streamly@composewell.com

8-- Stability : experimental

9-- Portability : GHC

10--

11module Streamly.Test.FileSystem.Event.Common

12 ( TestDesc

14 -- * Running tests

15 , runTests

16 , WatchRootType (..)

18 -- * Event predicates

19 , dirEvent

20 , fileEvent

22 -- * Tests

23 , dirCreate

24 , dirCreateWithParent

25 , dirDelete

26 , dirMove

27 , rootDirMove

29 , fileCreate

30 , fileCreateWithParent

31 , fileDelete

32 , fileModify

33 , fileMove

34 , rootFileMove

36 , commonTests

37 , commonRecTests

38 )

40where

42import Debug.Trace (trace)

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

44import Control.Monad (when)

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

46import Data.Bifunctor (first)

47import Data.Function ((&))

48import Data.Functor.Identity (runIdentity)

49import Data.List.NonEmpty (NonEmpty)

50import Data.Word (Word8)

51import Streamly.Data.Array (Array)

52import System.Directory

53 ( createDirectory

54 , createDirectoryIfMissing

55 , createDirectoryLink

56 , removeFile

57 , removePathForcibly

58 , renameDirectory

59 , renamePath

60 )

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

62import System.IO

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

64 , hClose)

65import System.IO.Temp (withSystemTempDirectory)

67import qualified Data.List.NonEmpty as NonEmpty

68import qualified Streamly.Internal.Data.Array as Array

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

70import qualified Streamly.Unicode.Stream as Unicode

72#if defined(FILESYSTEM_EVENT_LINUX)

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

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

75#elif defined(FILESYSTEM_EVENT_DARWIN)

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

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

78#elif defined(FILESYSTEM_EVENT_WINDOWS)

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

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

81#else

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

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

84#endif

86import Test.Hspec

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

89-- Check generated events

90-------------------------------------------------------------------------------

92type EventChecker =

93 FilePath -- watch root

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

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

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

97 -> IO ()

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

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

101eventMatches ev (expectedPath, f) =

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

103 (evPath == expectedPath && f ev)

104

105 where

106

107 utf8ToString :: Array Word8 -> String

108 utf8ToString =

109 runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.read

110

111 evPath = utf8ToString (Event.getAbsPath ev)

112

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

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

115

116checkEvents :: EventWatcher -> EventChecker

117checkEvents watcher rootPath targetPath mvar matchList = do

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

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

120

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

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

123

124 paths <- mapM toUtf8 [rootPath]

125 watcher (NonEmpty.fromList paths)

126 & Stream.before (putMVar mvar ())

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

128 & Stream.scanl' finder matchList1

129 & Stream.takeWhile (not . null)

130 & Stream.drain

131

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

133-- Run tests

134-------------------------------------------------------------------------------

135

136type TestDesc =

137 ( String -- test description

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

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

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

141 )

142

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

144data WatchRootType =

145 DirType -- watch root is a directory

146 | FileType -- watch root is a file

147 | SymLinkResolvedPath -- symlink to a directory,

148 -- Event contains path via the resolved dir

149 | SymLinkOrigPath -- symlink to a directory,

150 -- Event contains path via the original symlink

151 deriving Show

152

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

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

155 it desc $ runOneTest `shouldReturn` ()

156

157 where

158

159 fseventDir :: String

160 fseventDir = "fsevent_dir"

161

162 runOneTest = do

163 sync <- newEmptyMVar

164 withSystemTempDirectory fseventDir $ \fp -> do

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

166 target <-

167 case symlinkStyle of

168 DirType -> do

169 createDirectory root

170 return root

171 FileType -> do

172 openFile root WriteMode >>= hClose

173 return root

174 SymLinkResolvedPath -> do

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

176 createDirectory tgt

177 createDirectoryLink tgt root

178 return tgt

179 SymLinkOrigPath -> do

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

181 createDirectory tgt

182 createDirectoryLink tgt root

183 return root

184

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

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

187 -- we add a delay here.

188 startWatchAndCheck root target sync

189

190 startWatchAndCheck root target sync = do

191 pre root

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

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

194 let check = checker root target sync expected

195 fsOps = Stream.fromEffect $ runFSOps root sync

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

197

198 runFSOps fp sync = do

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

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

201 -- delay as well. Do we?

202 takeMVar sync >> threadDelay 200000

203 ops fp

204 threadDelay 10000000

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

206

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

208-- Test descriptions

209-------------------------------------------------------------------------------

210

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

212

213#if defined(FILESYSTEM_EVENT_DARWIN)

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

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

216#elif defined(FILESYSTEM_EVENT_LINUX)

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

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

219#else

220dirEvent = id

221fileEvent = id

222#endif

223

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

225-- XXX Add symlink and hardlink tests

226-- XXX Add exception condition tests

227

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

229-- Dir tests

230-------------------------------------------------------------------------------

231

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

233createParent file parent = do

234 createDirectoryIfMissing True (parent </> takeDirectory file)

235

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

237createDirWithParent dir parent =

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

239

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

241createDir dir parent =

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

243

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

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

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

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

248dirCreateWithParent ::

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

250dirCreateWithParent dir events =

251 ( "dir created (" ++ dir ++ ")"

252 , const (return ())

253 , createDirWithParent dir

254 , events dir

255 )

256

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

258dirCreate dir events =

259 ( "dir created (" ++ dir ++ ")"

260 , createParent dir

261 , createDir dir

262 , events dir

263 )

264

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

266dirDelete dir events =

267 ( "dir deleted (" ++ dir ++ ")"

268 , createDirWithParent dir

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

270 , events dir

271 )

272

273dirMove ::

274 String

275 -> String

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

277 -> TestDesc

278dirMove dir1 dir2 events =

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

280 , createDirWithParent dir1

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

282 , events dir1 dir2

283 )

284

285rootDirMove ::

286 String

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

288 -> TestDesc

289rootDirMove suffix events =

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

291 , const (return ())

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

293 , events ""

294 )

295

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

297-- File tests

298-------------------------------------------------------------------------------

299

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

301createFileWithParent file parent = do

302 when (not (null file)) $

303 createDirectoryIfMissing True (parent </> takeDirectory file)

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

305

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

307createFile file parent =

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

309

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

311fileCreate file1 events =

312 ( "File created (" ++ file1 ++ ")"

313 , createParent file1

314 , createFile file1

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

316 )

317

318-- | See comments in dirCreateWithParent

319fileCreateWithParent ::

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

321fileCreateWithParent file1 events =

322 ( "File created (" ++ file1 ++ ")"

323 , const (return ())

324 , createFileWithParent file1

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

326 )

327

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

329fileDelete file1 events =

330 ( "File deleted (" ++ file1 ++ ")"

331 , createFileWithParent file1

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

333 , events file1

334 )

335

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

337fileModify file1 events =

338 ( "File modified (" ++ file1 ++ ")"

339 , createFileWithParent file1

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

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

342 )

343

344fileMove ::

345 String

346 -> String

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

348 -> TestDesc

349fileMove file1 file2 events =

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

351 , createFileWithParent file1

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

353 , (file1, fileEvent Event.isMoved)

354 : (file2, fileEvent Event.isMoved)

355 : events file1 file2

356 )

357

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

359rootFileMove suffix events =

360 ( "File moved (" ++ suffix ++ ")"

361 , const (return ())

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

363 , events ""

364 )

365

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

367-- Common test bundles

368-------------------------------------------------------------------------------

369

370withParent :: [Char] -> [Char] -> [Char]

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

372

373testsWithParent :: String -> [TestDesc]

374testsWithParent p =

375 [ dirCreate

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

377 , dirDelete

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

379 , dirMove

380 (withParent p "dir1")

381 (withParent p "dir2")

382 (\dir1 dir2 ->

383 [ (dir1, dirEvent Event.isMoved)

384 , (dir2, dirEvent Event.isMoved)

385 ]

386 )

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

388 , fileDelete

389 (withParent p "file1")

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

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

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

393 ]

394

395commonTests :: [TestDesc]

396commonTests = testsWithParent ""

397

398commonRecTests :: [TestDesc]

399commonRecTests = testsWithParent "subdir"

400

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

402-- Running tests

403-------------------------------------------------------------------------------

404

405runTests ::

406 String

407 -> String

408 -> EventWatcher

409 -> WatchRootType

410 -> [TestDesc]

411 -> IO ()

412runTests modName watchType watcher rootType tests = do

413 hSetBuffering stdout NoBuffering

414 hspec

415 $ describe modName

416 $ describe watchType

417 $ do

418 let checker = checkEvents watcher

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

420 $ mapM_ (driver checker rootType) tests