IOV2FilesystemTests.hs (8788B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOV2FilesystemTests (ioV2FilesystemTests) where 3 import qualified IOV2.Filesystem as F 4 import qualified IOV2.Resources as R 5 import qualified System.Posix.Files as P 6 import qualified System.Posix.Files.ByteString as PB 7 import qualified Data.ByteString.Char8 as B 8 import System.IO.Temp (withSystemTempDirectory) 9 import Control.Concurrent 10 import Control.Concurrent.STM 11 import Control.Exception 12 import Control.Monad 13 import Data.IORef 14 import Data.List (sort) 15 import System.Timeout (timeout) 16 import Test.Tasty 17 import Test.Tasty.HUnit 18 19 right :: Show e => Either e a -> IO a 20 right = either (\e -> assertFailure (show e) >> error "assertion") pure 21 category name result = case result of 22 Left p -> R.category p @?= name 23 _ -> assertFailure ("expected "++name) 24 fixture body = withSystemTempDirectory "v2-fs" $ \dir -> 25 bracket R.newRuntime (\r -> void (R.closeScope r 0)) (\r -> body r dir) 26 allNames r scope token = do 27 name <- R.nextDirectory r scope token >>= right 28 case name of Nothing -> pure []; Just value -> (value:) <$> allNames r scope token 29 wait done = timeout 3000000 (readMVar done) >>= maybe (assertFailure "timeout" >> error "timeout") pure 30 31 ioV2FilesystemTests = localOption (mkTimeout 30000000) $ testGroup "IO v2 filesystem" 32 [ testCase "stat/lstat distinguish symlinks, dangling links, directory and file" $ fixture $ \_ dir -> do 33 B.writeFile (dir++"/file") (B.pack "abc") 34 P.createSymbolicLink "file" (dir++"/link") 35 P.createSymbolicLink "absent" (dir++"/dangling") 36 F.statPath True (dir++"/file") >>= (@?= Right (F.Regular 3)) 37 F.statPath True dir >>= (@?= Right F.Directory) 38 F.statPath True (dir++"/link") >>= (@?= Right (F.Regular 3)) 39 F.statPath False (dir++"/link") >>= (@?= Right F.Symlink) 40 F.statPath False (dir++"/dangling") >>= (@?= Right F.Symlink) 41 F.statPath True (dir++"/dangling") >>= category "not-found" 42 F.statPath True "" >>= category "invalid-argument" 43 , testCase "strict directory creation and nonrecursive removal retain contents" $ fixture $ \_ dir -> do 44 F.createDirectory (dir++"/new") >>= (@?= Right ()) 45 F.createDirectory (dir++"/new") >>= category "already-exists" 46 B.writeFile (dir++"/new/item") (B.pack "keep") 47 F.removeDirectory (dir++"/new") >>= \reply -> case reply of 48 Left p -> R.progress p @?= "unknown" 49 _ -> assertFailure "removed nonempty directory" 50 B.readFile (dir++"/new/item") >>= (@?= B.pack "keep") 51 F.removeFile (dir++"/new/item") >>= (@?= Right ()) 52 F.removeDirectory (dir++"/new") >>= (@?= Right ()) 53 F.statPath False (dir++"/new") >>= category "not-found" 54 , testCase "rename replaces names; unlink removes link rather than its target" $ fixture $ \_ dir -> do 55 B.writeFile (dir++"/old") (B.pack "new") 56 B.writeFile (dir++"/target") (B.pack "prior") 57 F.renamePath (dir++"/old") (dir++"/target") >>= (@?= Right ()) 58 F.statPath True (dir++"/old") >>= category "not-found" 59 B.readFile (dir++"/target") >>= (@?= B.pack "new") 60 P.createSymbolicLink "target" (dir++"/link") 61 F.removeFile (dir++"/link") >>= (@?= Right ()) 62 B.readFile (dir++"/target") >>= (@?= B.pack "new") 63 F.removeFile dir >>= category "io-error" 64 , testCase "directory is bounded per entry, excludes dots, has sticky EOF and normal lifetime" $ fixture $ \r dir -> do 65 let names = ["a", "λ", "space name", "line\nname"] 66 forM_ names $ \name -> B.writeFile (dir++"/"++name) B.empty 67 d <- F.openDirectory r 0 dir >>= right 68 allNames r 0 d >>= (\actual -> sort actual @?= sort names) 69 R.nextDirectory r 0 d >>= (@?= Right Nothing) 70 R.nextDirectory r 0 d >>= (@?= Right Nothing) 71 R.readSome r 0 d 1 >>= category "wrong-kind" 72 R.fileSize r 0 d >>= category "wrong-kind" 73 R.closeResource r 0 d >>= (@?= Right ()) 74 R.nextDirectory r 0 d >>= category "stale-handle" 75 R.liveCounts r >>= (@?= (1,3)) 76 , testCase "directory cursor follows opened inode across rename and transfer" $ fixture $ \r dir -> do 77 F.createDirectory (dir++"/old") >>= right 78 B.writeFile (dir++"/old/item") B.empty 79 d <- F.openDirectory r 0 (dir++"/old") >>= right 80 F.renamePath (dir++"/old") (dir++"/new") >>= right 81 F.createDirectory (dir++"/old") >>= right 82 (scope, tokens) <- atomically (R.reserveChildSTM r 0 [d]) >>= right 83 case tokens of 84 [fresh] -> allNames r scope fresh >>= (@?= ["item"]) 85 _ -> assertFailure "transfer failed" 86 R.nextDirectory r 0 d >>= category "stale-handle" 87 R.closeScope r scope >>= (@?= []) 88 R.liveCounts r >>= (@?= (1,3)) 89 , testCase "IO failure poisons cursor without replay and close runs once" $ fixture $ \r _ -> do 90 calls <- newIORef (0::Int); closed <- newIORef (0::Int) 91 d <- R.acquire r 0 (F.directoryBackend 92 (modifyIORef' calls (+1) >> ioError (userError "read fault")) 93 (modifyIORef' closed (+1))) >>= right 94 R.nextDirectory r 0 d >>= category "io-error" 95 R.nextDirectory r 0 d >>= category "invalid-state" 96 readIORef calls >>= (@?= 1) 97 R.closeResource r 0 d >>= (@?= Right ()) 98 R.closeScope r 0 >>= (@?= []) 99 readIORef closed >>= (@?= 1) 100 , testCase "failed raw close reports uncertainty and is never retried" $ fixture $ \r _ -> do 101 calls <- newIORef (0::Int) 102 d <- R.acquire r 0 (F.directoryBackend (pure "") 103 (modifyIORef' calls (+1) >> ioError (userError "close fault"))) >>= right 104 R.closeResource r 0 d >>= \reply -> case reply of 105 Left p -> R.progress p @?= "unknown" 106 _ -> assertFailure "close fault disappeared" 107 R.closeResource r 0 d >>= category "stale-handle" 108 R.closeScope r 0 >>= (@?= []) 109 readIORef calls >>= (@?= 1) 110 , testCase "async close settlement cannot reuse a possibly freed directory pointer" $ fixture $ \r _ -> do 111 calls <- newIORef (0::Int) 112 d <- R.acquire r 0 (F.directoryBackend (pure "") 113 (modifyIORef' calls (+1) >> throwIO ThreadKilled)) >>= right 114 result <- try (R.closeResource r 0 d) 115 case result of 116 Left (_ :: AsyncException) -> pure () 117 Right _ -> assertFailure "async close swallowed" 118 R.closeScope r 0 >>= (@?= []) 119 readIORef calls >>= (@?= 1) 120 , testCase "invalid Unicode, components and excess names poison without demanding excess character" $ fixture $ \r _ -> do 121 forM_ [("\xdcff", "invalid-encoding"),("a/b", "invalid-name"), 122 (replicate 4096 'a' ++ [error "excess name character forced"], "invalid-name")] $ \(name, expected) -> do 123 d <- R.acquire r 0 (F.directoryBackend (pure name) (pure ())) >>= right 124 R.nextDirectory r 0 d >>= category expected 125 R.nextDirectory r 0 d >>= category "invalid-state" 126 R.closeResource r 0 d >>= (@?= Right ()) 127 , testCase "actual non-Unicode directory entry fails rather than emitting replacement text" $ fixture $ \r dir -> do 128 PB.createSymbolicLink (B.pack "absent") (B.pack (dir++"/") <> B.singleton '\xff') 129 d <- F.openDirectory r 0 dir >>= right 130 R.nextDirectory r 0 d >>= category "invalid-encoding" 131 R.nextDirectory r 0 d >>= category "invalid-state" 132 , testCase "cancelled cursor holds one lease, poisons, and releases before settlement" $ fixture $ \r _ -> do 133 entered <- newEmptyMVar; gate <- newEmptyMVar; done <- newEmptyMVar 134 closed <- newIORef False 135 d <- R.acquire r 0 (F.directoryBackend (putMVar entered () >> takeMVar gate) 136 (writeIORef closed True)) >>= right 137 bracket (forkFinally (R.nextDirectory r 0 d) (putMVar done)) 138 (\worker -> killThread worker >> void (wait done)) $ \worker -> do 139 takeMVar entered 140 R.nextDirectory r 0 d >>= category "busy" 141 atomically (R.reserveChildSTM r 0 [d]) >>= category "busy" 142 readIORef closed >>= (@?= False) 143 killThread worker 144 wait done >>= \outcome -> case outcome of 145 Left _ -> pure () 146 Right _ -> assertFailure "cancelled operation resumed" 147 R.nextDirectory r 0 d >>= category "invalid-state" 148 R.closeResource r 0 d >>= (@?= Right ()) 149 readIORef closed >>= (@?= True) 150 , testCase "EOF never re-enters host and repeated dot entries have bounded scanning" $ fixture $ \r _ -> do 151 count <- newIORef (0::Int) 152 d <- R.acquire r 0 (F.directoryBackend (modifyIORef' count (+1) >> pure "") (pure ())) >>= right 153 replicateM_ 10 (R.nextDirectory r 0 d >>= (@?= Right Nothing)) 154 readIORef count >>= (@?= 1) 155 looping <- R.acquire r 0 (F.directoryBackend (pure ".") (pure ())) >>= right 156 R.nextDirectory r 0 looping >>= category "invalid-state" 157 R.nextDirectory r 0 looping >>= category "invalid-state" 158 ]