IOStorageTests.hs (26349B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOStorageTests (ioStorageTests) where 3 4 import qualified IO.Resources as R 5 import qualified IO.Staging as S 6 import qualified IO.Digest as D 7 import Control.Concurrent 8 import Control.Concurrent.STM 9 import Control.Exception 10 import Control.Monad 11 import Data.IORef 12 import Foreign.C.Error (eXDEV, errnoToIOError) 13 import Data.List (sort, isInfixOf) 14 import qualified Data.ByteString.Char8 as BS 15 import System.Directory 16 import System.Posix.IO (closeFd) 17 import System.Posix.Files (getFdStatus, fileID, deviceID) 18 import System.IO.Temp (withSystemTempDirectory) 19 import Test.Tasty 20 import Test.Tasty.HUnit 21 22 right :: Show e => Either e a -> IO a 23 right (Right value) = pure value 24 right (Left e) = assertFailure (show e) >> error "assertion failed" 25 category :: String -> Either R.Problem a -> Assertion 26 category name (Left p) = R.category p @?= name 27 category name _ = assertFailure ("expected " ++ name) 28 withRuntime :: (R.Runtime -> IO a) -> IO a 29 withRuntime = bracket R.newRuntime (\r -> void (R.closeScope r 0)) 30 write :: R.Runtime -> R.Token -> String -> IO () 31 write r token bytes = R.writeSome r 0 token (BS.pack bytes) >>= (@?= Right (length bytes)) 32 sealed :: S.StageOps -> R.Runtime -> FilePath -> String -> IO R.Token 33 sealed ops r dir bytes = do 34 token <- S.openStageWith ops r 0 dir >>= right 35 write r token bytes 36 R.sealStage r 0 token >>= (@?= Right ()) 37 pure token 38 39 ioStorageTests :: TestTree 40 ioStorageTests = localOption (mkTimeout 30000000) $ testGroup "IO staging and digests" 41 [ testCase "independent SHA-256 vectors, bounded updates and consuming finish" $ withRuntime $ \r -> do 42 forM_ [(0,"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), 43 (1000,"cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0")] $ \(n,expected) -> do 44 token <- D.openDigest r 0 "sha256" >>= right 45 replicateM_ n (R.updateDigest r 0 token (BS.replicate 1000 'a') >>= (@?= Right ())) 46 R.finishDigest r 0 token >>= (@?= Right expected) 47 R.finishDigest r 0 token >>= category "invalid-state" 48 R.updateDigest r 0 token (BS.pack "x") >>= category "invalid-state" 49 R.closeResource r 0 token >>= (@?= Right ()) 50 D.openDigest r 0 "sha999" >>= category "unsupported" 51 token <- D.openDigest r 0 "sha256" >>= right 52 R.updateDigest r 0 token BS.empty >>= category "invalid-bound" 53 R.updateDigest r 0 token (BS.replicate 4097 'a') >>= category "invalid-bound" 54 R.writeSome r 0 token (BS.pack "a") >>= category "wrong-kind" 55 forM_ ["a","b","c"] $ \chunk -> R.updateDigest r 0 token (BS.pack chunk) >>= (@?= Right ()) 56 R.finishDigest r 0 token >>= (@?= Right "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad") 57 , testCase "staging is invisible at destination until sealed publication" $ 58 withSystemTempDirectory "v2-stage" $ \dir -> withRuntime $ \r -> do 59 S.openStage r 0 "" >>= category "invalid-argument" 60 let target = dir ++ "/target" 61 BS.writeFile target (BS.pack "old") 62 token <- S.openStage r 0 dir >>= right 63 R.publishStage r 0 token True target >>= category "invalid-state" 64 write r token "new" 65 BS.readFile target >>= (@?= BS.pack "old") 66 R.sealStage r 0 token >>= (@?= Right ()) 67 BS.readFile target >>= (@?= BS.pack "old") 68 R.writeSome r 0 token (BS.pack "extra") >>= category "invalid-state" 69 R.publishStage r 0 token True target >>= (@?= Right "published") 70 BS.readFile target >>= (@?= BS.pack "new") 71 R.publishStage r 0 token True target >>= category "invalid-state" 72 R.closeResource r 0 token >>= (@?= Right ()) 73 listDirectory dir >>= (@?= ["target"]) 74 , testCase "no-replace preserves existing winner and abandon removes staging" $ 75 withSystemTempDirectory "v2-stage" $ \dir -> withRuntime $ \r -> do 76 BS.writeFile (dir++"/target") (BS.pack "winner") 77 token <- sealed S.nativeOps r dir "loser" 78 R.publishStage r 0 token False (dir++"/target") >>= (@?= Right "exists") 79 BS.readFile (dir++"/target") >>= (@?= BS.pack "winner") 80 R.closeResource r 0 token >>= (@?= Right ()) 81 listDirectory dir >>= (@?= ["target"]) 82 , testCase "concurrent no-replace has exactly one whole-file winner" $ 83 withSystemTempDirectory "v2-race" $ \dir -> withRuntime $ \r -> do 84 a <- sealed S.nativeOps r dir "first" 85 b <- sealed S.nativeOps r dir "second" 86 gate <- newEmptyMVar 87 outputs <- newEmptyMVar 88 forM_ [a,b] $ \token -> void $ forkIO $ readMVar gate >> 89 R.publishStage r 0 token False (dir++"/target") >>= putMVar outputs 90 putMVar gate () 91 x <- takeMVar outputs >>= right 92 y <- takeMVar outputs >>= right 93 sort [x,y] @?= ["exists","published"] 94 bytes <- BS.readFile (dir++"/target") 95 assertBool "whole winner" (bytes `elem` map BS.pack ["first","second"]) 96 R.closeScope r 0 >>= (@?= []) 97 listDirectory dir >>= (@?= ["target"]) 98 , testCase "file sync failure prevents publication and cleanup preserves old target" $ 99 withSystemTempDirectory "v2-sync" $ \dir -> withRuntime $ \r -> do 100 let ops = S.nativeOps { S.syncFile = \_ -> ioError (userError "sync failed") } 101 BS.writeFile (dir++"/target") (BS.pack "old") 102 token <- S.openStageWith ops r 0 dir >>= right 103 write r token "new" 104 R.sealStage r 0 token >>= category "io-error" 105 R.publishStage r 0 token True (dir++"/target") >>= category "invalid-state" 106 R.closeScope r 0 >>= (@?= []) 107 BS.readFile (dir++"/target") >>= (@?= BS.pack "old") 108 listDirectory dir >>= (@?= ["target"]) 109 , testCase "post-publication sync failure reports visible output, never rolls it back" $ 110 withSystemTempDirectory "v2-sync" $ \dir -> withRuntime $ \r -> do 111 let ops = S.nativeOps { S.syncDirectory = \_ -> ioError (userError "directory sync failed") } 112 token <- sealed ops r dir "new" 113 outcome <- R.publishStage r 0 token True (dir++"/target") 114 case outcome of Left p -> R.progress p @?= "published"; _ -> assertFailure "failure hidden" 115 R.publishStage r 0 token True (dir++"/target") >>= category "invalid-state" 116 R.closeScope r 0 >>= (@?= []) 117 BS.readFile (dir++"/target") >>= (@?= BS.pack "new") 118 listDirectory dir >>= (@?= ["target"]) 119 , testCase "ambiguous namespace failure freezes stage and never deletes destination" $ 120 withSystemTempDirectory "v2-ambiguous" $ \dir -> withRuntime $ \r -> do 121 let ops = S.nativeOps { S.replaceName = \from to -> renameFile from to >> ioError (userError "lost reply") } 122 token <- sealed ops r dir "new" 123 outcome <- R.publishStage r 0 token True (dir++"/target") 124 case outcome of Left p -> R.progress p @?= "unknown"; _ -> assertFailure "ambiguity lost" 125 R.publishStage r 0 token True (dir++"/target") >>= category "invalid-state" 126 R.closeScope r 0 >>= (@?= []) 127 BS.readFile (dir++"/target") >>= (@?= BS.pack "new") 128 , testCase "partial failed staged write cannot be sealed or published" $ 129 withSystemTempDirectory "v2-write" $ \dir -> withRuntime $ \r -> do 130 let ops = S.nativeOps { S.putBytes = \h bytes -> BS.hPut h (BS.take 2 bytes) >> ioError (userError "partial write") } 131 token <- S.openStageWith ops r 0 dir >>= right 132 result <- R.writeSome r 0 token (BS.pack "abcdef") 133 case result of Left p -> R.progress p @?= "unknown"; _ -> assertFailure "write failure hidden" 134 R.sealStage r 0 token >>= category "invalid-state" 135 R.closeScope r 0 >>= (@?= []) 136 listDirectory dir >>= (@?= []) 137 , testCase "cancellation settles a staged write before abandonment" $ 138 withSystemTempDirectory "v2-cancel" $ \dir -> withRuntime $ \r -> do 139 entered <- newEmptyMVar 140 blocked <- newEmptyMVar 141 finished <- newEmptyMVar 142 let ops = S.nativeOps { S.putBytes = \_ _ -> putMVar entered () >> takeMVar blocked } 143 token <- S.openStageWith ops r 0 dir >>= right 144 worker <- forkIO $ (try (R.writeSome r 0 token (BS.pack "x")) :: IO (Either SomeException (Either R.Problem Int))) >>= putMVar finished 145 takeMVar entered 146 R.sealStage r 0 token >>= category "busy" 147 killThread worker 148 result <- takeMVar finished 149 case result of Left _ -> pure (); _ -> assertFailure "cancelled write resumed" 150 R.sealStage r 0 token >>= category "invalid-state" 151 R.closeScope r 0 >>= (@?= []) 152 listDirectory dir >>= (@?= []) 153 , testCase "stage and digest transfer together, with old aliases invalidated" $ 154 withSystemTempDirectory "v2-transfer" $ \dir -> withRuntime $ \r -> do 155 stage <- S.openStage r 0 dir >>= right 156 digest <- D.openDigest r 0 "sha256" >>= right 157 (child, moved) <- atomically (R.reserveChildSTM r 0 [stage,digest]) >>= right 158 R.writeSome r 0 stage (BS.pack "abc") >>= category "stale-handle" 159 R.updateDigest r 0 digest (BS.pack "abc") >>= category "stale-handle" 160 case moved of 161 [freshStage,freshDigest] -> do 162 R.writeSome r child freshStage (BS.pack "abc") >>= (@?= Right 3) 163 R.updateDigest r child freshDigest (BS.pack "abc") >>= (@?= Right ()) 164 R.finishDigest r child freshDigest >>= (@?= Right "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad") 165 R.sealStage r child freshStage >>= (@?= Right ()) 166 R.publishStage r child freshStage False (dir++"/target") >>= (@?= Right "published") 167 _ -> assertFailure "transfer arity" 168 R.closeScope r child >>= (@?= []) 169 BS.readFile (dir++"/target") >>= (@?= BS.pack "abc") 170 listDirectory dir >>= (@?= ["target"]) 171 , testCase "cancelled seal closes its descriptor and abandons private output" $ 172 withSystemTempDirectory "v2-seal-cancel" $ \dir -> withRuntime $ \r -> do 173 entered <- newEmptyMVar 174 blocked <- newEmptyMVar 175 done <- newEmptyMVar 176 let ops = S.nativeOps { S.syncFile = \fd -> putMVar entered fd >> takeMVar blocked } 177 stage <- S.openStageWith ops r 0 dir >>= right 178 write r stage "abc" 179 worker <- forkIO $ (try (R.sealStage r 0 stage) :: IO (Either SomeException (Either R.Problem ()))) >>= putMVar done 180 fd <- takeMVar entered 181 original <- getFdStatus fd 182 killThread worker 183 takeMVar done >>= \outcome -> case outcome of Left _ -> pure (); _ -> assertFailure "seal resumed" 184 R.publishStage r 0 stage True (dir++"/target") >>= category "invalid-state" 185 R.closeScope r 0 >>= (@?= []) 186 descriptor <- try (getFdStatus fd) 187 case descriptor of 188 Left (_ :: IOException) -> pure () 189 Right current -> assertBool "original descriptor leaked" 190 ((deviceID current, fileID current) /= (deviceID original, fileID original)) 191 listDirectory dir >>= (@?= []) 192 , testCase "cancellation after namespace publication cannot undo visibility" $ 193 withSystemTempDirectory "v2-publish-cancel" $ \dir -> withRuntime $ \r -> do 194 entered <- newEmptyMVar 195 blocked <- newEmptyMVar 196 done <- newEmptyMVar 197 let ops = S.nativeOps { S.syncDirectory = \_ -> putMVar entered () >> takeMVar blocked } 198 stage <- sealed ops r dir "abc" 199 worker <- forkIO $ (try (R.publishStage r 0 stage True (dir++"/target")) :: IO (Either SomeException (Either R.Problem String))) >>= putMVar done 200 takeMVar entered 201 BS.readFile (dir++"/target") >>= (@?= BS.pack "abc") 202 killThread worker 203 takeMVar done >>= \outcome -> case outcome of Left _ -> pure (); _ -> assertFailure "publish resumed" 204 R.publishStage r 0 stage True (dir++"/target") >>= category "invalid-state" 205 R.closeScope r 0 >>= (@?= []) 206 BS.readFile (dir++"/target") >>= (@?= BS.pack "abc") 207 listDirectory dir >>= (@?= ["target"]) 208 , testCase "no-replace unlink failure reports published and cleanup retries only private name" $ 209 withSystemTempDirectory "v2-unlink" $ \dir -> withRuntime $ \r -> do 210 first <- newIORef True 211 let ops = S.nativeOps { S.removeName = \path -> do 212 failNow <- atomicModifyIORef' first (\value -> (False,value)) 213 if failNow then ioError (userError "unlink failed") else removeFile path } 214 stage <- sealed ops r dir "abc" 215 result <- R.publishStage r 0 stage False (dir++"/target") 216 case result of Left p -> R.progress p @?= "published"; _ -> assertFailure "unlink failure hidden" 217 R.closeScope r 0 >>= (@?= []) 218 BS.readFile (dir++"/target") >>= (@?= BS.pack "abc") 219 listDirectory dir >>= (@?= ["target"]) 220 , testCase "cross-directory publication succeeds but self-publication is rejected" $ 221 withSystemTempDirectory "v2-destination" $ \dir -> withRuntime $ \r -> do 222 createDirectory (dir++"/other") 223 a <- sealed S.nativeOps r dir "abc" 224 R.publishStage r 0 a True (dir++"/other/target") >>= (@?= Right "published") 225 BS.readFile (dir++"/other/target") >>= (@?= BS.pack "abc") 226 R.closeResource r 0 a >>= (@?= Right ()) 227 b <- sealed S.nativeOps r dir "abc" 228 names <- listDirectory dir 229 let temporary = head (filter (/= "other") names) 230 R.publishStage r 0 b True (dir++"/"++temporary) >>= category "invalid-destination" 231 R.closeScope r 0 >>= (@?= []) 232 listDirectory dir >>= (@?= ["other"]) 233 , testCase "cross-directory link and replace sync destination then source, preserving existing winners" $ 234 withSystemTempDirectory "v2-cross-directory" $ \dir -> withRuntime $ \r -> do 235 let source = dir++"/source"; target = dir++"/target" 236 createDirectory source 237 createDirectory target 238 synced <- newIORef [] 239 let ops = S.nativeOps { S.openDirectory = \path -> do 240 modifyIORef' synced (++ [path]) 241 S.openDirectory S.nativeOps path } 242 forM_ [False, True] $ \replace -> do 243 stage <- sealed ops r source (if replace then "replacement" else "new") 244 writeIORef synced [] 245 R.publishStage r 0 stage replace (target++"/object") >>= (@?= Right "published") 246 readIORef synced >>= (@?= [target, source]) 247 R.closeResource r 0 stage >>= (@?= Right ()) 248 listDirectory source >>= (@?= []) 249 BS.readFile (target++"/object") >>= (@?= BS.pack "replacement") 250 winner <- sealed ops r source "must not replace" 251 writeIORef synced [] 252 R.publishStage r 0 winner False (target++"/object") >>= (@?= Right "exists") 253 readIORef synced >>= (@?= []) -- exists is not an identity/durability claim 254 R.closeScope r 0 >>= (@?= []) 255 BS.readFile (target++"/object") >>= (@?= BS.pack "replacement") 256 listDirectory source >>= (@?= []) 257 , testCase "cross-filesystem syscall failures never fall back to copying or alter destination" $ 258 withSystemTempDirectory "v2-exdev" $ \dir -> withRuntime $ \r -> do 259 let target = dir++"/target" 260 createDirectory target 261 BS.writeFile (target++"/object") (BS.pack "keep") 262 calls <- newIORef (0 :: Int) 263 let unavailable _ destination = do 264 modifyIORef' calls (+1) 265 ioError (errnoToIOError "publish" eXDEV Nothing (Just destination)) 266 ops = S.nativeOps { S.linkName = unavailable, S.replaceName = unavailable } 267 forM_ [False, True] $ \replace -> do 268 stage <- sealed ops r dir "new" 269 outcome <- R.publishStage r 0 stage replace (target++"/object") 270 case outcome of 271 Left p -> R.progress p @?= "unknown" -- never turn errno into replay permission 272 _ -> assertFailure "cross-filesystem failure hidden" 273 R.publishStage r 0 stage replace (target++"/object") >>= category "invalid-state" 274 R.closeResource r 0 stage >>= (@?= Right ()) 275 BS.readFile (target++"/object") >>= (@?= BS.pack "keep") 276 readIORef calls >>= (@?= 2) 277 listDirectory dir >>= (@?= ["target"]) 278 , testCase "failure syncing either publication directory preserves published data" $ 279 withSystemTempDirectory "v2-cross-sync" $ \dir -> withRuntime $ \r -> do 280 let source = dir++"/source"; target = dir++"/target" 281 createDirectory source 282 createDirectory target 283 forM_ [1,2 :: Int] $ \failureAt -> do 284 count <- newIORef (0 :: Int) 285 let ops = S.nativeOps { S.syncDirectory = \fd -> do 286 n <- atomicModifyIORef' count (\n -> (n+1,n+1)) 287 if n == failureAt then ioError (userError "directory sync failed") 288 else S.syncDirectory S.nativeOps fd } 289 stage <- sealed ops r source "visible" 290 outcome <- R.publishStage r 0 stage True (target++"/object") 291 case outcome of 292 Left p -> do 293 R.progress p @?= "published" 294 assertBool "sync diagnostic" ("directory sync failed" `isInfixOf` R.detail p) 295 _ -> assertFailure "directory sync failure hidden" 296 R.publishStage r 0 stage True (target++"/object") >>= category "invalid-state" 297 R.closeResource r 0 stage >>= (@?= Right ()) 298 listDirectory source >>= (@?= []) 299 BS.readFile (target++"/object") >>= (@?= BS.pack "visible") 300 , testCase "cross-directory ambiguous link error never unlinks the published destination" $ 301 withSystemTempDirectory "v2-cross-ambiguous" $ \dir -> withRuntime $ \r -> do 302 let target = dir++"/target" 303 createDirectory target 304 let ops = S.nativeOps { S.linkName = \source destination -> do 305 S.linkName S.nativeOps source destination 306 ioError (userError "reply lost after link") } 307 stage <- sealed ops r dir "visible" 308 outcome <- R.publishStage r 0 stage False (target++"/object") 309 case outcome of Left p -> R.progress p @?= "unknown"; _ -> assertFailure "ambiguity hidden" 310 R.closeScope r 0 >>= (@?= []) 311 listDirectory dir >>= (@?= ["target"]) 312 BS.readFile (target++"/object") >>= (@?= BS.pack "visible") 313 , testCase "cancellation during source-directory sync preserves cross-directory publication" $ 314 withSystemTempDirectory "v2-cross-cancel" $ \dir -> withRuntime $ \r -> do 315 let target = dir++"/target" 316 createDirectory target 317 count <- newIORef (0 :: Int) 318 entered <- newEmptyMVar 319 blocked <- newEmptyMVar 320 done <- newEmptyMVar 321 let ops = S.nativeOps { S.syncDirectory = \fd -> do 322 n <- atomicModifyIORef' count (\n -> (n+1,n+1)) 323 if n == 2 then putMVar entered () >> takeMVar blocked else S.syncDirectory S.nativeOps fd } 324 stage <- sealed ops r dir "visible" 325 worker <- forkIO $ (try (R.publishStage r 0 stage False (target++"/object")) :: IO (Either SomeException (Either R.Problem String))) >>= putMVar done 326 takeMVar entered 327 killThread worker 328 takeMVar done >>= \outcome -> case outcome of Left _ -> pure (); _ -> assertFailure "cancellation lost" 329 R.closeScope r 0 >>= (@?= []) 330 listDirectory dir >>= (@?= ["target"]) 331 BS.readFile (target++"/object") >>= (@?= BS.pack "visible") 332 , testCase "source-directory close failure is published and never retries the descriptor" $ 333 withSystemTempDirectory "v2-cross-close" $ \dir -> withRuntime $ \r -> do 334 let target = dir++"/target" 335 createDirectory target 336 calls <- newIORef (0 :: Int) 337 let ops = S.nativeOps { S.closeDescriptor = \fd -> do 338 n <- atomicModifyIORef' calls (\n -> (n+1,n+1)) 339 closeFd fd 340 when (n == 3) (ioError (userError "source directory close")) } 341 stage <- sealed ops r dir "visible" 342 outcome <- R.publishStage r 0 stage True (target++"/object") 343 case outcome of Left p -> R.progress p @?= "published"; _ -> assertFailure "close failure hidden" 344 R.closeScope r 0 >>= (@?= []) 345 readIORef calls >>= (@?= 3) 346 BS.readFile (target++"/object") >>= (@?= BS.pack "visible") 347 , testCase "cross-directory publication cannot target another stage's private namespace" $ 348 withSystemTempDirectory "v2-cross-private" $ \dir -> withRuntime $ \r -> do 349 let target = dir++"/target" 350 createDirectory target 351 stage <- sealed S.nativeOps r dir "source" 352 other <- sealed S.nativeOps r target "private" 353 names <- listDirectory target 354 R.publishStage r 0 stage True (target++"/"++head names) >>= category "invalid-destination" 355 R.publishStage r 0 other False (target++"/safe") >>= (@?= Right "published") 356 R.closeScope r 0 >>= (@?= []) 357 BS.readFile (target++"/safe") >>= (@?= BS.pack "private") 358 listDirectory target >>= (@?= ["safe"]) 359 , testCase "repeated digest/stage scopes leave no private files or registry history" $ 360 withSystemTempDirectory "v2-repeat" $ \dir -> withRuntime $ \r -> do 361 replicateM_ 100 $ do 362 child <- R.childScope r 0 >>= right 363 _ <- S.openStage r child dir >>= right 364 digest <- D.openDigest r child "sha256" >>= right 365 R.updateDigest r child digest (BS.pack "abc") >>= (@?= Right ()) 366 R.closeScope r child >>= (@?= []) 367 R.liveCounts r >>= (@?= (1,3)) 368 listDirectory dir >>= (@?= []) 369 , testCase "failed sync keeps its primary error and reports descriptor release separately" $ 370 withSystemTempDirectory "v2-sync-close" $ \dir -> withRuntime $ \r -> do 371 let ops = S.nativeOps 372 { S.syncFile = \_ -> ioError (userError "primary sync") 373 , S.closeDescriptor = \fd -> closeFd fd >> ioError (userError "secondary close") } 374 stage <- S.openStageWith ops r 0 dir >>= right 375 write r stage "abc" 376 outcome <- R.sealStage r 0 stage 377 case outcome of 378 Left p -> assertBool "sync error masked" ("primary sync" `isInfixOf` R.detail p) 379 _ -> assertFailure "sync error hidden" 380 errors <- R.closeScope r 0 381 case errors of 382 [p] -> assertBool "release error hidden" ("secondary close" `isInfixOf` R.detail p) 383 _ -> assertFailure (show errors) 384 listDirectory dir >>= (@?= []) 385 , testCase "failed descriptor close is never retried after possible descriptor reuse" $ 386 withSystemTempDirectory "io-close-once" $ \dir -> withRuntime $ \r -> do 387 attempts <- newIORef (0 :: Int) 388 let ops = S.nativeOps { S.closeDescriptor = \fd -> do 389 modifyIORef' attempts (+1) 390 closeFd fd 391 ioError (userError "close reported failure") } 392 stage <- S.openStageWith ops r 0 dir >>= right 393 write r stage "abc" 394 R.sealStage r 0 stage >>= category "io-error" 395 R.closeScope r 0 >>= (@?= []) 396 readIORef attempts >>= (@?= 1) 397 listDirectory dir >>= (@?= []) 398 , testCase "unexpected descriptor release fault still attempts private-name cleanup" $ 399 withSystemTempDirectory "v2-release-fault" $ \dir -> withRuntime $ \r -> do 400 let ops = S.nativeOps 401 { S.syncFile = \_ -> ioError (userError "sync failed") 402 , S.closeDescriptor = \fd -> closeFd fd >> throwIO (ErrorCall "unexpected close") } 403 stage <- S.openStageWith ops r 0 dir >>= right 404 R.sealStage r 0 stage >>= category "io-error" 405 errors <- R.closeScope r 0 406 case errors of [p] -> R.category p @?= "backend-fault"; _ -> assertFailure (show errors) 407 listDirectory dir >>= (@?= []) 408 , testCase "directory sync failure preserves its error and owns directory release until settlement" $ 409 withSystemTempDirectory "v2-directory-close" $ \dir -> withRuntime $ \r -> do 410 calls <- newIORef (0 :: Int) 411 let ops = S.nativeOps 412 { S.syncDirectory = \_ -> ioError (userError "primary directory sync") 413 , S.closeDescriptor = \fd -> do 414 count <- atomicModifyIORef' calls (\n -> (n+1,n)) 415 closeFd fd 416 when (count == 1) (ioError (userError "secondary directory close")) } 417 stage <- sealed ops r dir "abc" 418 result <- R.publishStage r 0 stage False (dir++"/target") 419 case result of 420 Left p -> do 421 R.progress p @?= "published" 422 assertBool "primary hidden" ("primary directory sync" `isInfixOf` R.detail p) 423 _ -> assertFailure "directory sync failure hidden" 424 errors <- R.closeScope r 0 425 case errors of 426 [p] -> assertBool "directory release hidden" ("secondary directory close" `isInfixOf` R.detail p) 427 _ -> assertFailure (show errors) 428 readIORef calls >>= (@?= 2) 429 BS.readFile (dir++"/target") >>= (@?= BS.pack "abc") 430 listDirectory dir >>= (@?= ["target"]) 431 , testCase "publication cannot overwrite another stage's private name" $ 432 withSystemTempDirectory "v2-private-namespace" $ \dir -> withRuntime $ \r -> do 433 first <- sealed S.nativeOps r dir "first" 434 original <- listDirectory dir 435 second <- S.openStage r 0 dir >>= right 436 write r second "second" 437 names <- listDirectory dir 438 assertBool "temporary naming contract" (all (".tricu-stage-" `isInfixOf`) names) 439 let other = head (filter (`notElem` original) names) 440 R.publishStage r 0 first True (dir++"/"++other) >>= category "invalid-destination" 441 write r second "tail" 442 R.sealStage r 0 second >>= (@?= Right ()) 443 R.publishStage r 0 second False (dir++"/safe") >>= (@?= Right "published") 444 R.closeScope r 0 >>= (@?= []) 445 BS.readFile (dir++"/safe") >>= (@?= BS.pack "secondtail") 446 listDirectory dir >>= (@?= ["safe"]) 447 , testCase "explicit abandonment reports removal failure" $ 448 withSystemTempDirectory "v2-cleanup" $ \dir -> withRuntime $ \r -> do 449 attempts <- newIORef (0 :: Int) 450 let ops = S.nativeOps { S.removeName = \_ -> modifyIORef' attempts (+1) >> ioError (userError "remove failed") } 451 token <- S.openStageWith ops r 0 dir >>= right 452 R.closeResource r 0 token >>= category "io-error" 453 readIORef attempts >>= (@?= 1) 454 R.liveCounts r >>= (@?= (1,3)) 455 ]