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

git.iko.soy/streamly

on 021ac26 help sign in

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

422 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 as Stream

70import qualified Streamly.Internal.Data.Stream.Concurrent as Stream

71import qualified Streamly.Unicode.Stream as Unicode

73#if defined(FILESYSTEM_EVENT_LINUX)

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

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

76#elif defined(FILESYSTEM_EVENT_DARWIN)

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

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

79#elif defined(FILESYSTEM_EVENT_WINDOWS)

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

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

82#else

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

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

85#endif

87import Test.Hspec

89-------------------------------------------------------------------------------

90-- Check generated events

91-------------------------------------------------------------------------------

93type EventChecker =

94 FilePath -- watch root

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

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

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

98 -> IO ()

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

100

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

102eventMatches ev (expectedPath, f) =

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

104 (evPath == expectedPath && f ev)

105

106 where

107

108 utf8ToString :: Array Word8 -> String

109 utf8ToString =

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

111

112 evPath = utf8ToString (Event.getAbsPath ev)

113

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

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

116

117checkEvents :: EventWatcher -> EventChecker

118checkEvents watcher rootPath targetPath mvar matchList = do

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

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

121

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

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

124

125 paths <- mapM toUtf8 [rootPath]

126 watcher (NonEmpty.fromList paths)

127 & Stream.before (putMVar mvar ())

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

129 & Stream.scanl' finder matchList1

130 & Stream.takeWhile (not . null)

131 & Stream.drain

132

133-------------------------------------------------------------------------------

134-- Run tests

135-------------------------------------------------------------------------------

136

137type TestDesc =

138 ( String -- test description

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

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

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

142 )

143

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

145data WatchRootType =

146 DirType -- watch root is a directory

147 | FileType -- watch root is a file

148 | SymLinkResolvedPath -- symlink to a directory,

149 -- Event contains path via the resolved dir

150 | SymLinkOrigPath -- symlink to a directory,

151 -- Event contains path via the original symlink

152 deriving Show

153

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

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

156 it desc $ runOneTest `shouldReturn` ()

157

158 where

159

160 fseventDir :: String

161 fseventDir = "fsevent_dir"

162

163 runOneTest = do

164 sync <- newEmptyMVar

165 withSystemTempDirectory fseventDir $ \fp -> do

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

167 target <-

168 case symlinkStyle of

169 DirType -> do

170 createDirectory root

171 return root

172 FileType -> do

173 openFile root WriteMode >>= hClose

174 return root

175 SymLinkResolvedPath -> do

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

177 createDirectory tgt

178 createDirectoryLink tgt root

179 return tgt

180 SymLinkOrigPath -> do

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

182 createDirectory tgt

183 createDirectoryLink tgt root

184 return root

185

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

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

188 -- we add a delay here.

189 startWatchAndCheck root target sync

190

191 startWatchAndCheck root target sync = do

192 pre root

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

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

195 let check = checker root target sync expected

196 fsOps = Stream.fromEffect $ runFSOps root sync

197 Stream.drain

198 $ Stream.parListEagerFst [Stream.fromEffect check, fsOps]

199

200 runFSOps fp sync = do

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

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

203 -- delay as well. Do we?

204 takeMVar sync >> threadDelay 200000

205 ops fp

206 threadDelay 10000000

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

208

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

210-- Test descriptions

211-------------------------------------------------------------------------------

212

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

214

215#if defined(FILESYSTEM_EVENT_DARWIN)

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

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

218#elif defined(FILESYSTEM_EVENT_LINUX)

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

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

221#else

222dirEvent = id

223fileEvent = id

224#endif

225

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

227-- XXX Add symlink and hardlink tests

228-- XXX Add exception condition tests

229

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

231-- Dir tests

232-------------------------------------------------------------------------------

233

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

235createParent file parent = do

236 createDirectoryIfMissing True (parent </> takeDirectory file)

237

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

239createDirWithParent dir parent =

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

241

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

243createDir dir parent =

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

245

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

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

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

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

250dirCreateWithParent ::

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

252dirCreateWithParent dir events =

253 ( "dir created (" ++ dir ++ ")"

254 , const (return ())

255 , createDirWithParent dir

256 , events dir

257 )

258

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

260dirCreate dir events =

261 ( "dir created (" ++ dir ++ ")"

262 , createParent dir

263 , createDir dir

264 , events dir

265 )

266

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

268dirDelete dir events =

269 ( "dir deleted (" ++ dir ++ ")"

270 , createDirWithParent dir

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

272 , events dir

273 )

274

275dirMove ::

276 String

277 -> String

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

279 -> TestDesc

280dirMove dir1 dir2 events =

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

282 , createDirWithParent dir1

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

284 , events dir1 dir2

285 )

286

287rootDirMove ::

288 String

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

290 -> TestDesc

291rootDirMove suffix events =

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

293 , const (return ())

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

295 , events ""

296 )

297

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

299-- File tests

300-------------------------------------------------------------------------------

301

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

303createFileWithParent file parent = do

304 when (not (null file)) $

305 createDirectoryIfMissing True (parent </> takeDirectory file)

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

307

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

309createFile file parent =

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

311

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

313fileCreate file1 events =

314 ( "File created (" ++ file1 ++ ")"

315 , createParent file1

316 , createFile file1

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

318 )

319

320-- | See comments in dirCreateWithParent

321fileCreateWithParent ::

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

323fileCreateWithParent file1 events =

324 ( "File created (" ++ file1 ++ ")"

325 , const (return ())

326 , createFileWithParent file1

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

328 )

329

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

331fileDelete file1 events =

332 ( "File deleted (" ++ file1 ++ ")"

333 , createFileWithParent file1

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

335 , events file1

336 )

337

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

339fileModify file1 events =

340 ( "File modified (" ++ file1 ++ ")"

341 , createFileWithParent file1

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

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

344 )

345

346fileMove ::

347 String

348 -> String

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

350 -> TestDesc

351fileMove file1 file2 events =

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

353 , createFileWithParent file1

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

355 , (file1, fileEvent Event.isMoved)

356 : (file2, fileEvent Event.isMoved)

357 : events file1 file2

358 )

359

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

361rootFileMove suffix events =

362 ( "File moved (" ++ suffix ++ ")"

363 , const (return ())

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

365 , events ""

366 )

367

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

369-- Common test bundles

370-------------------------------------------------------------------------------

371

372withParent :: [Char] -> [Char] -> [Char]

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

374

375testsWithParent :: String -> [TestDesc]

376testsWithParent p =

377 [ dirCreate

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

379 , dirDelete

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

381 , dirMove

382 (withParent p "dir1")

383 (withParent p "dir2")

384 (\dir1 dir2 ->

385 [ (dir1, dirEvent Event.isMoved)

386 , (dir2, dirEvent Event.isMoved)

387 ]

388 )

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

390 , fileDelete

391 (withParent p "file1")

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

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

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

395 ]

396

397commonTests :: [TestDesc]

398commonTests = testsWithParent ""

399

400commonRecTests :: [TestDesc]

401commonRecTests = testsWithParent "subdir"

402

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

404-- Running tests

405-------------------------------------------------------------------------------

406

407runTests ::

408 String

409 -> String

410 -> EventWatcher

411 -> WatchRootType

412 -> [TestDesc]

413 -> IO ()

414runTests modName watchType watcher rootType tests = do

415 hSetBuffering stdout NoBuffering

416 hspec

417 $ describe modName

418 $ describe watchType

419 $ do

420 let checker = checkEvents watcher

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

422 $ mapM_ (driver checker rootType) tests