IOV2Tests.hs (19791B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOV2Tests (ioV2Tests) where 3 4 import qualified IOV2.Resources as R 5 import qualified IOV2.Driver as V 6 import IODriver (runIO) 7 import Runtime 8 import Control.Concurrent 9 import Control.Concurrent.STM 10 import Control.Exception 11 import Control.Monad 12 import qualified Data.ByteString as BS 13 import Data.IORef 14 import System.Directory (listDirectory) 15 import System.IO.Temp (withSystemTempDirectory) 16 import qualified System.Timeout as Timeout 17 import Test.Tasty 18 import Test.Tasty.HUnit 19 20 -- Independent wire construction: no production encoder/catalogue expectations. 21 request :: String -> String -> T -> T 22 request group operation arguments = Fork (ofNumber 10) 23 (Fork (ofString group) (Fork (ofNumber 1) (Fork (ofString operation) arguments))) 24 25 right :: Show e => Either e a -> IO a 26 right (Right value) = pure value 27 right (Left e) = assertFailure (show e) >> error "assertion failed" 28 categoryIs :: String -> Either R.Problem a -> Assertion 29 categoryIs expected result = case result of 30 Left p -> R.category p @?= expected 31 Right _ -> assertFailure ("expected " ++ expected) 32 33 withRuntime :: (R.Runtime -> IO a) -> IO a 34 withRuntime = bracket R.newRuntime (\r -> void (R.closeScope r R.rootScope)) 35 spawn :: IO a -> IO (ThreadId, MVar (Either SomeException a)) 36 spawn action = do 37 result <- newEmptyMVar 38 tid <- forkIO (try action >>= putMVar result) 39 pure (tid, result) 40 wait :: MVar a -> IO a 41 wait result = Timeout.timeout 3000000 (takeMVar result) >>= maybe (assertFailure "thread timeout" >> error "timeout") pure 42 43 ioV2Tests :: TestTree 44 ioV2Tests = localOption (mkTimeout 30000000) $ testGroup "IO v2 resource/file foundation" 45 [ testCase "bounded binary copy, EOF, no grants" $ 46 withSystemTempDirectory "v2-copy" $ \dir -> withRuntime $ \runtime -> do 47 let bytes = BS.pack (take 20003 (cycle [0..255])) 48 BS.writeFile (dir++"/in") bytes 49 child <- R.childScope runtime 0 >>= right 50 reader <- R.openReader runtime child (dir++"/in") >>= right 51 writer <- R.openWriter runtime child (dir++"/out") >>= right 52 let copy = do 53 part <- R.readSome runtime child reader 997 >>= right 54 unless (BS.null part) $ do 55 n <- R.writeSome runtime child writer part >>= right 56 n @?= BS.length part 57 copy 58 copy 59 R.readSome runtime child reader 5 >>= (@?= Right BS.empty) 60 R.closeScope runtime child >>= (@?= []) 61 BS.readFile (dir++"/out") >>= (@?= bytes) 62 R.liveCounts runtime >>= (@?= (1,3)) 63 R.readSome runtime 0 reader 1 >>= categoryIs "stale-handle" 64 , testCase "scope ancestry, wrong kind, bounds and cross-run handles" $ 65 withRuntime $ \runtime -> withRuntime $ \other -> do 66 a <- R.childScope runtime 0 >>= right 67 b <- R.childScope runtime 0 >>= right 68 child <- R.childScope runtime a >>= right 69 reader <- R.acquire runtime a (pure (R.Reader (const (pure BS.empty)) (pure ()))) >>= right 70 R.readSome runtime child reader 1 >>= (@?= Right BS.empty) 71 R.readSome runtime b reader 1 >>= categoryIs "out-of-scope" 72 R.readSome runtime 0 reader 1 >>= categoryIs "out-of-scope" 73 R.readSome other 0 reader 1 >>= categoryIs "stale-handle" 74 R.writeSome runtime a reader (BS.singleton 1) >>= categoryIs "wrong-kind" 75 forM_ [0,4097] $ \n -> R.readSome runtime a reader n >>= categoryIs "invalid-bound" 76 R.closeResource runtime a reader >>= (@?= Right ()) 77 R.closeResource runtime a reader >>= categoryIs "stale-handle" 78 , testCase "second acquisition failure releases first at scope exit" $ 79 withSystemTempDirectory "v2-open" $ \dir -> withRuntime $ \runtime -> do 80 released <- newIORef False 81 scope <- R.childScope runtime 0 >>= right 82 _ <- R.acquire runtime scope (pure (R.Reader (const (pure BS.empty)) (writeIORef released True))) >>= right 83 R.openReader runtime scope (dir++"/missing") >>= categoryIs "not-found" 84 R.closeScope runtime scope >>= (@?= []) 85 readIORef released >>= (@?= True) 86 , testCase "release order and cleanup errors do not skip remaining resources" $ 87 withRuntime $ \runtime -> do 88 order <- newIORef ([] :: [Int]) 89 scope <- R.childScope runtime 0 >>= right 90 forM_ [1,2,3] $ \i -> do 91 _ <- R.acquire runtime scope (pure (R.Reader (const (pure BS.empty)) 92 (modifyIORef' order (++[i]) >> when (i == 2) (ioError (userError "close failure"))))) >>= right 93 pure () 94 errors <- R.closeScope runtime scope 95 map R.operation errors @?= ["close"] 96 readIORef order >>= (@?= [3,2,1]) 97 R.liveCounts runtime >>= (@?= (1,3)) 98 , testCase "pending lease is busy; close waits; cancellation releases lease" $ 99 withRuntime $ \runtime -> do 100 entered <- newEmptyMVar 101 blocked <- newEmptyMVar 102 released <- newEmptyMVar 103 token <- R.acquire runtime 0 (pure (R.Reader (\_ -> putMVar entered () >> takeMVar blocked) 104 (putMVar released ()))) >>= right 105 (reader, readDone) <- spawn (R.readSome runtime 0 token 1) 106 wait entered 107 R.readSome runtime 0 token 1 >>= categoryIs "busy" 108 (_, closeDone) <- spawn (R.closeResource runtime 0 token) 109 -- Wait for closing admission, not a timing guess about the close worker. 110 let closing = do 111 result <- R.readSome runtime 0 token 1 112 case result of 113 Left p | R.category p == "closed-handle" -> pure () 114 Left p | R.category p == "busy" -> yield >> closing 115 _ -> assertFailure "unexpected lease state" 116 (Timeout.timeout 3000000 closing >>= (@?= Just ())) `onException` killThread reader 117 tryTakeMVar released >>= (@?= Nothing) 118 killThread reader 119 readResult <- wait readDone 120 case readResult of Left e -> assertBool "async cancellation" (case fromException e :: Maybe AsyncException of Just ThreadKilled -> True; _ -> False) 121 Right _ -> assertFailure "cancelled read resumed" 122 wait closeDone >>= right >>= (@?= Right ()) 123 wait released 124 R.liveCounts runtime >>= (@?= (1,3)) 125 , testCase "scope closure drains an acquisition already admitted" $ 126 withRuntime $ \runtime -> do 127 entered <- newEmptyMVar 128 proceed <- newEmptyMVar 129 released <- newEmptyMVar 130 scope <- R.childScope runtime 0 >>= right 131 (_, acquired) <- spawn (R.acquire runtime scope (putMVar entered () >> takeMVar proceed >> 132 pure (R.Reader (const (pure BS.empty)) (putMVar released ())))) 133 wait entered 134 (_, closed) <- spawn (R.closeScope runtime scope) 135 putMVar proceed () 136 wait acquired >>= right >>= right >>= \_ -> pure () 137 wait closed >>= right >>= (@?= []) 138 wait released 139 R.liveCounts runtime >>= (@?= (1,3)) 140 , testCase "cancelled acquisition leaves no admission or resource behind" $ 141 withRuntime $ \runtime -> do 142 entered <- newEmptyMVar 143 gate <- newEmptyMVar 144 scope <- R.childScope runtime 0 >>= right 145 (worker, finished) <- spawn (R.acquire runtime scope (putMVar entered () >> takeMVar gate)) 146 wait entered 147 killThread worker 148 outcome <- wait finished 149 case outcome of Left _ -> pure (); Right _ -> assertFailure "acquisition resumed" 150 R.closeScope runtime scope >>= (@?= []) 151 R.liveCounts runtime >>= (@?= (1,3)) 152 , testCase "partial write progress and invalid backend progress" $ 153 withRuntime $ \runtime -> do 154 writer <- R.acquire runtime 0 (pure (R.Writer (\_ -> pure 2) (pure ()))) >>= right 155 R.writeSome runtime 0 writer (BS.pack [1,2,3]) >>= (@?= Right 2) 156 badWriter <- R.acquire runtime 0 (pure (R.Writer (\_ -> pure 0) (pure ()))) >>= right 157 result <- R.writeSome runtime 0 badWriter (BS.singleton 1) 158 categoryIs "io-error" result 159 case result of Left p -> R.progress p @?= "unknown"; _ -> assertFailure "bad progress accepted" 160 , testCase "driver host cancellation closes resources and never resumes continuation" $ 161 withSystemTempDirectory "v2-cancel" $ \dir -> do 162 runtime <- R.newRuntime 163 entered <- newEmptyMVar 164 gate <- newEmptyMVar 165 released <- newIORef False 166 token@(R.Token identity key) <- R.acquire runtime 0 167 (pure (R.Writer (\_ -> putMVar entered () >> takeMVar gate) (writeIORef released True))) >>= right 168 let encoded = ofList [ofString "io.v2.resource", ofNumber identity, ofNumber key] 169 scope = ofList [ofString "io.v2.scope", ofNumber identity, Leaf] 170 write = request "stream" "write" (Fork encoded (ofBytes (BS.singleton 1))) 171 -- If resumed, this would create an observable file. 172 next = Fork Leaf (request "file" "open-writer" (Fork scope (ofString (dir++"/SHOULD-NOT-EXIST")))) 173 program = Fork (ofNumber 1) (Fork write next) 174 (worker, finished) <- spawn (V.runInRuntime runtime program) 175 wait entered 176 killThread worker 177 outcome <- wait finished 178 case outcome of Left e -> assertBool "async outcome not converted to Result" (case fromException e :: Maybe AsyncException of Just ThreadKilled -> True; _ -> False) 179 Right _ -> assertFailure "cancelled driver returned normally" 180 readIORef released >>= (@?= True) 181 R.liveCounts runtime >>= (@?= (0,0)) 182 R.writeSome runtime 0 token (BS.singleton 1) >>= categoryIs "stale-handle" 183 files <- listDirectory dir 184 files @?= [] 185 , testCase "driver preserves primary failure, aggregates bounded cleanup errors" $ do 186 runtime <- R.newRuntime 187 closed <- newIORef (0 :: Int) 188 replicateM_ 40 $ do 189 _ <- R.acquire runtime 0 (pure (R.Reader (const (pure BS.empty)) 190 (modifyIORef' closed (+1) >> throwIO (ErrorCall "backend close fault")))) >>= right 191 pure () 192 outcome <- V.runInRuntime runtime (Fork (ofNumber 2) (error "primary diagnostic forced")) 193 case outcome of 194 V.Failed _ errors -> do 195 length errors @?= 17 196 R.category (last errors) @?= "cleanup-omitted" 197 R.detail (last errors) @?= "24" 198 _ -> assertFailure "primary failure lost" 199 readIORef closed >>= (@?= 40) 200 R.liveCounts runtime >>= (@?= (0,0)) 201 , testCase "successful body becomes failed when cleanup fails" $ do 202 runtime <- R.newRuntime 203 _ <- R.acquire runtime 0 (pure (R.Reader (const (pure BS.empty)) (ioError (userError "close")))) >>= right 204 outcome <- V.runInRuntime runtime (Fork (ofNumber 0) Leaf) 205 case outcome of V.Failed _ [] -> pure (); _ -> assertFailure "cleanup failure silently discarded" 206 , testCase "repeated lexical scopes do not retain closed resources or scope history" $ 207 withRuntime $ \runtime -> replicateM_ 1000 $ do 208 scope <- R.childScope runtime 0 >>= right 209 _ <- R.acquire runtime scope (pure (R.Reader (const (pure BS.empty)) (pure ()))) >>= right 210 R.closeScope runtime scope >>= (@?= []) 211 R.liveCounts runtime >>= (@?= (1,3)) 212 , testCase "closing admission preserves child borrowing and child-local acquisition" $ 213 withRuntime $ \runtime -> do 214 released <- newIORef (0 :: Int) 215 let backend = pure (R.Reader (const (pure BS.empty)) (modifyIORef' released (+1))) 216 token <- R.acquire runtime 0 backend >>= right 217 child <- R.childScope runtime 0 >>= right 218 atomically (R.beginCloseScopeSTM runtime 0) 219 R.acquire runtime 0 backend >>= categoryIs "closed-scope" 220 R.childScope runtime 0 >>= categoryIs "closed-scope" 221 R.readSome runtime child token 1 >>= (@?= Right BS.empty) 222 local <- R.acquire runtime child backend >>= right 223 grandchild <- R.childScope runtime child >>= right 224 R.readSome runtime grandchild local 1 >>= (@?= Right BS.empty) 225 readIORef released >>= (@?= 0) 226 R.closeScope runtime child >>= (@?= []) 227 readIORef released >>= (@?= 1) 228 R.readSome runtime 0 token 1 >>= (@?= Right BS.empty) 229 R.closeScope runtime 0 >>= (@?= []) 230 readIORef released >>= (@?= 2) 231 R.liveCounts runtime >>= (@?= (0,0)) 232 , testCase "handoff rekeys aliases and preserves acquisition order, not argument order" $ 233 withRuntime $ \runtime -> do 234 order <- newIORef ([] :: [Int]) 235 let backend n = pure (R.Reader (const (pure (BS.singleton (fromIntegral n)))) 236 (modifyIORef' order (++[n]))) 237 first <- R.acquire runtime 0 (backend 1) >>= right 238 second <- R.acquire runtime 0 (backend 2) >>= right 239 (child, fresh) <- atomically (R.reserveChildSTM runtime 0 [second, first]) >>= right 240 case fresh of 241 [newSecond, newFirst] -> do 242 forM_ [first, second] $ \old -> do 243 R.readSome runtime child old 1 >>= categoryIs "stale-handle" 244 R.closeResource runtime 0 old >>= categoryIs "stale-handle" 245 R.readSome runtime 0 newFirst 1 >>= categoryIs "out-of-scope" 246 R.readSome runtime child newFirst 1 >>= (@?= Right (BS.singleton 1)) 247 R.readSome runtime child newSecond 1 >>= (@?= Right (BS.singleton 2)) 248 _ -> assertFailure "wrong transfer arity" 249 _ <- R.acquire runtime child (backend 3) >>= right 250 R.closeScope runtime child >>= (@?= []) 251 readIORef order >>= (@?= [3,2,1]) 252 R.liveCounts runtime >>= (@?= (1,3)) 253 , testCase "failed transfer validates all handles without partial movement" $ 254 withRuntime $ \runtime -> withRuntime $ \other -> do 255 let backend = pure (R.Reader (const (pure BS.empty)) (pure ())) 256 token <- R.acquire runtime 0 backend >>= right 257 foreignToken <- R.acquire other 0 backend >>= right 258 child <- R.childScope runtime 0 >>= right 259 local <- R.acquire runtime child backend >>= right 260 let rejected owner tokens expected = do 261 before <- R.liveCounts runtime 262 atomically (R.reserveChildSTM runtime owner tokens) >>= categoryIs expected 263 R.liveCounts runtime >>= (@?= before) 264 R.readSome runtime 0 token 1 >>= (@?= Right BS.empty) 265 R.readSome runtime child local 1 >>= (@?= Right BS.empty) 266 rejected 0 [token, token] "duplicate-handle" 267 rejected 0 [token, R.Token (-1) 999] "stale-handle" 268 rejected 0 [token, foreignToken] "stale-handle" 269 rejected 0 [token, local] "out-of-scope" 270 rejected child [local, token] "not-owner" 271 atomically (R.beginCloseScopeSTM runtime child) 272 rejected child [local] "closed-scope" 273 , testCase "handoff transaction rolls back with task-publication failure" $ 274 withRuntime $ \runtime -> do 275 token <- R.acquire runtime 0 (pure (R.Reader (const (pure BS.empty)) (pure ()))) >>= right 276 publication <- newTVarIO False 277 result <- try $ atomically $ do 278 reserved <- R.reserveChildSTM runtime 0 [token] 279 case reserved of 280 Left _ -> error "reservation should succeed" 281 Right _ -> writeTVar publication True >> throwSTM (ErrorCall "publication failed") 282 case result of Left (_ :: ErrorCall) -> pure (); Right () -> assertFailure "expected rollback" 283 readTVarIO publication >>= (@?= False) 284 R.liveCounts runtime >>= (@?= (1,4)) 285 R.readSome runtime 0 token 1 >>= (@?= Right BS.empty) 286 R.closeResource runtime 0 token >>= (@?= Right ()) 287 , testCase "handoff rejects a leased or closing resource, with no partial movement" $ 288 withRuntime $ \runtime -> do 289 entered <- newEmptyMVar 290 proceed <- newEmptyMVar 291 released <- newIORef False 292 first <- R.acquire runtime 0 (pure (R.Reader (const (pure BS.empty)) (pure ()))) >>= right 293 busy <- R.acquire runtime 0 (pure (R.Reader (\_ -> putMVar entered () >> takeMVar proceed) 294 (writeIORef released True))) >>= right 295 (_, reading) <- spawn (R.readSome runtime 0 busy 1) 296 wait entered 297 atomically (R.reserveChildSTM runtime 0 [first, busy]) >>= categoryIs "busy" 298 R.liveCounts runtime >>= (@?= (1,5)) 299 (_, closing) <- spawn (R.closeResource runtime 0 busy) 300 let marked = do 301 result <- atomically (R.reserveChildSTM runtime 0 [first, busy]) 302 case result of 303 Left e | R.category e == "closed-handle" -> pure () 304 Left e | R.category e == "busy" -> yield >> marked 305 _ -> assertFailure "unexpected transfer outcome" 306 Timeout.timeout 3000000 marked >>= (@?= Just ()) 307 R.readSome runtime 0 first 1 >>= (@?= Right BS.empty) 308 readIORef released >>= (@?= False) 309 putMVar proceed BS.empty 310 wait reading >>= right >>= (@?= Right BS.empty) 311 wait closing >>= right >>= (@?= Right ()) 312 R.liveCounts runtime >>= (@?= (1,4)) 313 , testCase "close versus handoff has one winner and one backend release" $ 314 replicateM_ 200 $ withRuntime $ \runtime -> do 315 released <- newIORef (0 :: Int) 316 token <- R.acquire runtime 0 (pure (R.Reader (const (pure BS.empty)) 317 (atomicModifyIORef' released (\n -> (n+1, ()))))) >>= right 318 gate <- newTVarIO False 319 let start = atomically (readTVar gate >>= check) 320 (_, moved) <- spawn (start >> atomically (R.reserveChildSTM runtime 0 [token])) 321 (_, closed) <- spawn (start >> R.closeResource runtime 0 token) 322 atomically (writeTVar gate True) 323 handoff <- wait moved >>= right 324 close <- wait closed >>= right 325 case handoff of 326 Right (child, [fresh]) -> do 327 categoryIs "stale-handle" close 328 readIORef released >>= (@?= 0) 329 R.readSome runtime child fresh 1 >>= (@?= Right BS.empty) 330 R.closeScope runtime child >>= (@?= []) 331 Left e -> do 332 assertBool "close won" (R.category e `elem` ["stale-handle", "closed-handle"]) 333 close @?= Right () 334 _ -> assertFailure "wrong handoff arity" 335 readIORef released >>= (@?= 1) 336 R.liveCounts runtime >>= (@?= (1,3)) 337 , testCase "strict octet decode stops without forcing excess element" $ do 338 V.decodeChunk (ofBytes (BS.pack [0..255])) @?= Right (BS.pack [0..255]) 339 assertBool "noncanonical zero rejected" (case V.decodeChunk (ofList [Fork Leaf Leaf]) of Left _ -> True; _ -> False) 340 let tooLong = foldr Fork (Fork (error "excess head forced") (error "excess suffix forced")) (replicate 4096 Leaf) 341 V.decodeChunk tooLong @?= Left "chunk exceeds bound" 342 , testCase "v2 dispatch, ordinary errors, lazy failure and version rejection" $ do 343 let action code x = Fork (ofNumber code) x 344 envelope version x = Fork (ofString "tricuIO") (Fork (ofNumber version) x) 345 runIO (envelope 2 (action 0 (ofNumber 7))) >>= (@?= Right (ofNumber 7)) 346 failed <- V.runDetailed (action 2 (error "diagnostic was forced")) 347 case failed of V.Failed _ [] -> pure (); _ -> assertFailure "terminal failure lost" 348 runIO (envelope 99 (action 0 Leaf)) >>= (@?= Left "Unsupported tricuIO version") 349 let badVersion = Fork Leaf (Fork (Stem Leaf) (Fork Leaf Leaf)) 350 runIO (Fork (ofString "tricuIO") (Fork badVersion (error "invalid version body forced"))) 351 >>= (@?= Left "invalid IO envelope version") 352 runIO (Fork (ofString "tricuIO") (Fork (ofNumber 65536) (error "excess version body forced"))) 353 >>= (@?= Left "invalid IO envelope version") 354 ordinary <- V.runDetailed (request "stream" "read" Leaf) 355 case ordinary of V.Completed (Fork Leaf _) -> pure (); _ -> assertFailure "argument failure not ordinary Result" 356 ]