Resources.hs (32059B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 -- Scoped native resources. No Tree interpretation or application policy here. 3 -- Resource kinds share lifetime/lease rules; task supervision is in IO.Tasks. 4 module IO.Resources 5 ( Runtime, Scope, Token(..), Backend(..), FileOps(..), DuplexOps(..), ListenerOps(..), Endpoint(..), Problem(..), newRuntime, rootScope 6 , childScope, closeScope, acquire, openReader, openWriter, readSome, writeSome 7 , withTemporary, syncFile 8 , withReaderLease, withWriterLease, withInternalResource, closeInternalResource 9 , closeResource, liveCounts, chunkLimit, runtimeIdentity, isAncestor, combineErrors 10 , beginCloseScopeSTM, reserveChildSTM 11 , openAppender, openUpdate, seekFile, filePosition, fileSize, resizeFile, positionLimit 12 , nextDirectory, acceptConnection, shutdownWrite, socketAddress 13 , StandardStream(..), newRuntimeWithStreams, standardStream 14 , sealStage, publishStage, updateDigest, finishDigest, resourceFault, ioProblem 15 ) where 16 17 import qualified IO.Descriptor as Descriptor 18 import Control.Concurrent.MVar 19 import Control.Concurrent.STM 20 import Control.Exception 21 import Control.Monad (foldM, unless, when) 22 import qualified Data.ByteString as BS 23 import qualified Data.Map.Strict as M 24 import qualified Data.Set as S 25 import Data.List (foldl') 26 import Data.IORef 27 import Data.Bits ((.&.), (.|.), complement) 28 import Data.Word (Word8, Word16, Word32) 29 import Text.Read (readMaybe) 30 import Data.Unique (newUnique, hashUnique) 31 import System.IO 32 import System.IO.Error 33 34 -- IDs never recur within a run; the run identity rejects cross-run handles. 35 type Scope = Integer 36 data Token = Token !Integer !Integer deriving (Eq, Show) 37 data Problem = Problem { category :: String, operation :: String, detail :: String 38 , progress :: String } deriving (Eq, Show) 39 data Backend = Reader (Int -> IO BS.ByteString) (IO ()) 40 | Writer (BS.ByteString -> IO Int) (IO ()) 41 | Staged (BS.ByteString -> IO Int) (IO ()) (Bool -> FilePath -> IO String) (IO ()) 42 | Digest (BS.ByteString -> IO ()) (IO String) (IO ()) 43 | Inherited Backend 44 | File FileOps 45 | Directory (IO (Maybe String)) (IO ()) 46 | Duplex DuplexOps 47 | Listener ListenerOps 48 | Internal (IO ()) 49 50 data Endpoint = IPv4 (Word8,Word8,Word8,Word8) Word16 51 | IPv6 (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16) Word32 Word16 52 deriving (Eq, Show) 53 data DuplexOps = DuplexOps 54 { duplexRead :: Int -> IO BS.ByteString 55 , duplexWrite :: BS.ByteString -> IO Int 56 , duplexShutdownWrite :: IO () 57 , duplexLocal :: IO Endpoint 58 , duplexPeer :: IO Endpoint 59 , duplexRelease :: IO () 60 } 61 data ListenerOps = ListenerOps 62 { listenerAccept :: IO Backend 63 , listenerLocal :: IO Endpoint 64 , listenerRelease :: IO () 65 } 66 -- Bit 0 leases the read direction, bit 1 the write direction. Non-duplex 67 -- operations always lease both. Close/handoff require BOTH directions idle. 68 data Access = Exclusive | ReadDirection | WriteDirection 69 leaseBits :: Access -> Backend -> Word8 70 leaseBits ReadDirection (Duplex _) = 1 71 leaseBits WriteDirection (Duplex _) = 2 72 leaseBits _ _ = 3 73 -- File cursor operations and byte IO share ONE registry lease. Optional methods 74 -- express access mode, not separate handles/cursors or independent lifetimes. 75 data FileOps = FileOps 76 { fileReadAction :: Maybe (Int -> IO BS.ByteString) 77 , fileWriteAction :: Maybe (BS.ByteString -> IO Int) 78 , fileSeekAction :: Maybe (Integer -> IO ()) 79 , filePositionAction :: Maybe (IO Integer) 80 , fileSizeAction :: IO Integer 81 , fileResizeAction :: Maybe (Integer -> IO ()) 82 -- Acquire (synchronization action, once-only release); registered before use. 83 , fileSyncActions :: Maybe (IO (IO (), IO ())) 84 , fileReleaseAction :: IO () 85 } 86 positionLimit :: Integer 87 positionLimit = 2^(63 :: Int)-1 88 -- Backend state errors are ordinary operation failures; unrelated synchronous 89 -- faults remain terminal task faults, not a catch-all recoverable Result. 90 newtype ResourceFault = ResourceFault Problem deriving Show 91 instance Exception ResourceFault 92 resourceFault :: Problem -> IO a 93 resourceFault = throwIO . ResourceFault 94 data Resource = Resource !Scope Backend (TVar Word8) (TVar Bool) (MVar ()) 95 data ScopeState = ScopeState (Maybe Scope) !Bool !Int 96 -- Scope Bool is admission, not permission for existing leases to complete. 97 data State = State !Integer (M.Map Scope ScopeState) (M.Map Integer Resource) 98 data Runtime = Runtime !Integer (TVar State) 99 100 chunkLimit :: Int 101 chunkLimit = 4096 102 rootScope :: Scope 103 rootScope = 0 104 -- Three fixed root entries exist for the run, including during parent joining. 105 -- No lazy acquisition into a closing root and no per-lookup aliases/history. 106 -- These are borrowed process handles: no mode/buffering changes or OS close. 107 data StandardStream = StandardInput | StandardOutput | StandardError deriving (Enum) 108 newRuntime :: IO Runtime 109 newRuntime = newRuntimeWithStreams stdin stdout stderr 110 newRuntimeWithStreams :: Handle -> Handle -> Handle -> IO Runtime 111 newRuntimeWithStreams input output diagnostic = do 112 identity <- toInteger . hashUnique <$> newUnique 113 let writer h = do 114 failed <- newIORef False 115 pure $ Writer (\bytes -> mask $ \restore -> do 116 poisoned <- readIORef failed 117 when poisoned (resourceFault (Problem "invalid-state" "write" 118 "inherited writer failed; progress is uncertain" "unknown")) 119 -- A failed flush can leave host-buffered bytes. Never implicitly retry 120 -- them with the next write. The embedding still owns that buffer. 121 restore (BS.hPut h bytes >> hFlush h) `onException` writeIORef failed True 122 pure (BS.length bytes)) (pure ()) 123 out <- writer output 124 err <- writer diagnostic 125 let backends = [Reader (BS.hGetSome input) (pure ()), out, err] 126 entries <- mapM (\backend -> Resource rootScope (Inherited backend) 127 <$> newTVarIO 0 <*> newTVarIO False <*> newMVar ()) backends 128 Runtime identity <$> newTVarIO (State 4 (M.singleton 0 (ScopeState Nothing True 0)) 129 (M.fromList (zip [1..3] entries))) 130 131 standardStream :: Runtime -> Scope -> StandardStream -> IO (Either Problem Token) 132 standardStream (Runtime identity state) current stream = atomically $ do 133 snapshot <- readTVar state 134 let token = Token identity (1 + toInteger (fromEnum stream)) 135 -- Resolve validation here, not in a lazy result retaining the registry snapshot. 136 case lookupResource identity current token snapshot of 137 Left fault -> pure (Left fault) 138 Right _ -> token `seq` pure (Right token) 139 140 internal :: Backend -> Bool 141 internal (Internal _) = True 142 internal _ = False 143 144 inherited :: Backend -> Bool 145 inherited (Inherited _) = True 146 inherited _ = False 147 usable :: Backend -> Backend 148 usable (Inherited backend) = backend 149 usable backend = backend 150 151 problem :: String -> String -> Problem 152 problem cat op = Problem cat op "" "none" 153 ioProblem :: String -> IOException -> Problem 154 ioProblem op e = Problem cat op (take 512 (show e)) (if op `elem` ["write", "read", "seek", "resize", "next", "close", "sync"] then "unknown" else "none") 155 where cat | isDoesNotExistError e = "not-found" 156 | isPermissionError e = "os-permission-denied" 157 | isAlreadyExistsError e = "already-exists" 158 | otherwise = "io-error" 159 160 -- Scheduler transactions can close admission before joining children, without 161 -- revoking their ancestor borrowing or closing their own open scopes. Resource 162 -- release is a separate step, performed only after task settlement. 163 beginCloseScopeSTM :: Runtime -> Scope -> STM () 164 beginCloseScopeSTM (Runtime _ state) scope = modifyTVar' state $ \(State n scopes resources) -> 165 State n (M.adjust (\(ScopeState p _ count) -> ScopeState p False count) scope scopes) resources 166 167 childScope :: Runtime -> Scope -> IO (Either Problem Scope) 168 childScope runtime parent = atomically $ fmap (fmap fst) (reserveChildSTM runtime parent []) 169 170 -- Low-level reservation, NOT a public spawn operation. A scheduler must combine 171 -- this transaction with task registration and opening a prestarted worker's gate. 172 -- Thread creation must precede commitment: a failed fork must not move resources. 173 -- STM rollback then covers the resource registry AND task publication together. 174 -- 175 -- Only resources owned by the attaching parent move; borrowed ancestor resources 176 -- stay borrowed. Every token is checked before any mutation. Rekeying invalidates 177 -- all old aliases, with no tombstones, and preserves original acquisition order 178 -- independently of the caller's handle-list order. Returned tokens follow input 179 -- order. No pending lease or explicit close may cross the handoff boundary. 180 reserveChildSTM :: Runtime -> Scope -> [Token] -> STM (Either Problem (Scope, [Token])) 181 reserveChildSTM (Runtime identity state) parent tokens = do 182 snapshot@(State next scopes resources) <- readTVar state 183 case M.lookup parent scopes of 184 Just (ScopeState _ True _) -> 185 if S.size (S.fromList [(run, key) | Token run key <- tokens]) /= length tokens 186 then pure (Left (problem "duplicate-handle" "transfer")) 187 else do 188 checked <- mapM (validate snapshot) tokens 189 case sequence checked of 190 Left e -> pure (Left e) 191 Right entries -> do 192 let ordered = M.toAscList (M.fromList entries) 193 moved = zip ordered [next+1..] 194 replacements = M.fromList [(old, new) | ((old, _), new) <- moved] 195 removeOld = foldr (M.delete . fst) resources entries 196 insertMoved acc ((_, Resource _ backend busy closing gate), key) = 197 M.insert key (Resource next backend busy closing gate) acc 198 finalResources = foldl' insertMoved removeOld moved 199 fresh (Token _ old) = Token identity (replacements M.! old) 200 freshTokens = map fresh tokens 201 -- Do not let lazy output tokens retain the moved backend records 202 -- through the replacement-map construction after the scope closes. 203 foldr (\token rest -> token `seq` rest) () freshTokens `seq` pure () 204 writeTVar state (State (next+1+toInteger (length entries)) 205 (M.insert next (ScopeState (Just parent) True 0) scopes) finalResources) 206 pure (Right (next, freshTokens)) 207 _ -> pure (Left (problem "closed-scope" "scope")) 208 where 209 validate snapshot token@(Token _ key) = case lookupResource identity parent token snapshot of 210 Left e -> pure (Left e) 211 Right resource@(Resource owner backend busy closing _) -> do 212 occupied <- readTVar busy 213 dead <- readTVar closing 214 pure $ if owner /= parent then Left (problem "not-owner" "transfer") 215 else if inherited backend then Left (problem "borrowed-resource" "transfer") 216 else if internal backend then Left (problem "internal-resource" "transfer") 217 else if dead then Left (problem "closed-handle" "transfer") 218 else if occupied /= 0 then Left (problem "busy" "transfer") 219 else Right (key, resource) 220 221 release :: Backend -> IO () 222 release (Internal done) = done 223 release (Duplex methods) = duplexRelease methods 224 release (Listener methods) = listenerRelease methods 225 release (Directory _ done) = done 226 release (File methods) = fileReleaseAction methods 227 release (Inherited _) = pure () 228 release (Reader _ done) = done 229 release (Writer _ done) = done 230 release (Staged _ _ _ done) = done 231 release (Digest _ _ done) = done 232 233 -- Acquisition is masked through registry publication, like bracket acquisition. 234 -- Backend acquisition must be exception-safe internally. Admission remains counted 235 -- until publication/failure, so scope closure cannot miss an in-flight acquisition. 236 acquire :: Runtime -> Scope -> IO Backend -> IO (Either Problem Token) 237 acquire (Runtime identity state) owner create = mask_ $ do 238 admitted <- atomically $ do 239 State next scopes resources <- readTVar state 240 case M.lookup owner scopes of 241 Just (ScopeState parent True pending) -> do 242 writeTVar state (State next (M.insert owner (ScopeState parent True (pending+1)) scopes) resources) 243 pure True 244 _ -> pure False 245 if not admitted then pure (Left (problem "closed-scope" "open")) else do 246 let leave = atomically $ modifyTVar' state $ \(State n scopes resources) -> 247 State n (M.adjust (\(ScopeState p a count) -> ScopeState p a (count-1)) owner scopes) resources 248 result <- try (bracketOnError create release $ \backend -> do 249 busy <- newTVarIO 0 250 closing <- newTVarIO False 251 gate <- newMVar () 252 atomically $ do 253 State next scopes resources <- readTVar state 254 writeTVar state (State (next+1) scopes (M.insert next (Resource owner backend busy closing gate) resources)) 255 pure (Token identity next)) `finally` leave 256 case result of 257 Right value -> pure (Right value) 258 Left (exception :: SomeException) 259 | Just (ResourceFault fault) <- fromException exception -> pure (Left fault) 260 | Just e <- fromException exception -> pure (Left (ioProblem "open" e)) 261 | otherwise -> throwIO exception 262 263 openReader, openWriter, openAppender, openUpdate :: Runtime -> Scope -> FilePath -> IO (Either Problem Token) 264 openReader = openFileResource ReadMode 265 openWriter = openFileResource WriteMode 266 openAppender = openFileResource AppendMode 267 openUpdate = openFileResource ReadWriteMode 268 269 openFileResource :: IOMode -> Runtime -> Scope -> FilePath -> IO (Either Problem Token) 270 openFileResource mode runtime scope path = acquire runtime scope $ 271 bracketOnError (openBinaryFile path mode) hClose $ \h -> do 272 hSetBuffering h NoBuffering 273 let readable = mode == ReadMode || mode == ReadWriteMode 274 writable = mode /= ReadMode 275 positioned = mode /= AppendMode 276 optional allowed action = if allowed then Just action else Nothing 277 seekable action = do 278 supported <- hIsSeekable h 279 unless supported (resourceFault (Problem "unsupported" "file" "file is not seekable" "none")) 280 action 281 resize size = seekable $ do 282 -- Synchronize/discard any read-ahead before changing length. Resizing 283 -- preserves the logical cursor, including a position beyond new EOF. 284 position <- hTell h 285 hSeek h AbsoluteSeek position 286 hSetFileSize h size 287 pure (File (FileOps 288 (optional readable (BS.hGetSome h)) 289 (optional writable (\bytes -> BS.hPut h bytes >> pure (BS.length bytes))) 290 (optional positioned (\position -> seekable (hSeek h AbsoluteSeek position))) 291 (optional positioned (seekable (hTell h))) 292 (hFileSize h) 293 (optional (writable && positioned) resize) 294 (Just $ do 295 -- Synchronize any read-ahead while preserving the logical cursor. Append 296 -- needs only flushing; the duplicate is used for fsync, never seeking. 297 when readable (seekable (hTell h >>= hSeek h AbsoluteSeek)) 298 when writable (hFlush h) 299 Descriptor.duplicateSync h) 300 (hClose h))) 301 302 -- Validating bounds precedes backend IO. Query replies are checked too, so a 303 -- backend cannot inject a negative/out-of-range natural into the tree protocol. 304 fileOperation :: Runtime -> Scope -> Token -> String -> (FileOps -> Maybe (IO a)) -> IO (Either Problem a) 305 fileOperation runtime scope token op select = withLease runtime scope token op isFile $ \backend -> case backend of 306 File methods -> case select methods of 307 Just action -> action 308 Nothing -> resourceFault (Problem "unsupported" op "operation unavailable in this file mode" "none") 309 _ -> error "validated file kind" 310 where isFile (File _) = True 311 isFile _ = False 312 313 syncFile :: Runtime -> Scope -> Token -> IO (Either Problem ()) 314 syncFile runtime scope token = fileOperation runtime scope token "sync" $ \methods -> 315 fmap (\allocate -> withTemporary runtime scope "sync" allocate id >>= either resourceFault pure) 316 (fileSyncActions methods) 317 318 seekFile, resizeFile :: Runtime -> Scope -> Token -> Integer -> IO (Either Problem ()) 319 seekFile runtime scope token position 320 | position < 0 || position > positionLimit = pure (Left (problem "invalid-bound" "seek")) 321 | otherwise = fileOperation runtime scope token "seek" (fmap ($ position) . fileSeekAction) 322 resizeFile runtime scope token size 323 | size < 0 || size > positionLimit = pure (Left (problem "invalid-bound" "resize")) 324 | otherwise = fileOperation runtime scope token "resize" (fmap ($ size) . fileResizeAction) 325 326 filePosition, fileSize :: Runtime -> Scope -> Token -> IO (Either Problem Integer) 327 filePosition runtime scope token = fileOperation runtime scope token "position" 328 (fmap checkedPosition . filePositionAction) 329 fileSize runtime scope token = fileOperation runtime scope token "size" 330 (Just . checkedPosition . fileSizeAction) 331 checkedPosition :: IO Integer -> IO Integer 332 checkedPosition action = do 333 value <- action 334 unless (value >= 0 && value <= positionLimit) 335 (resourceFault (Problem "unsupported" "file" "position outside supported range" "none")) 336 pure value 337 338 inside :: Scope -> Scope -> M.Map Scope ScopeState -> Bool 339 inside current owner scopes = case M.lookup current scopes of 340 Nothing -> False 341 Just (ScopeState parent _ _) -> current == owner || maybe False (\p -> inside p owner scopes) parent 342 343 lookupResource :: Integer -> Scope -> Token -> State -> Either Problem Resource 344 lookupResource identity current (Token run key) (State _ scopes resources) 345 | run /= identity = Left (problem "stale-handle" "resource") 346 | otherwise = case M.lookup key resources of 347 Nothing -> Left (problem "stale-handle" "resource") 348 Just resource@(Resource owner _ _ _ _) 349 | inside current owner scopes -> Right resource 350 | otherwise -> Left (problem "out-of-scope" "resource") 351 352 withLease :: Runtime -> Scope -> Token -> String -> (Backend -> Bool) -> (Backend -> IO a) -> IO (Either Problem a) 353 withLease = withAccess Exclusive 354 355 -- Host-owned temporary resources are registered for lexical cleanup but are not 356 -- public handles. Even a guessed registry key cannot read, close or transfer one. 357 -- Their active operation still has a lease, so scope release waits for it. 358 withInternalResource :: Runtime -> Scope -> Token -> String -> IO a -> IO (Either Problem a) 359 withInternalResource runtime scope token op action = withLease runtime scope token op internal (const action) 360 361 closeInternalResource :: Runtime -> Scope -> Token -> IO (Either Problem ()) 362 closeInternalResource runtime@(Runtime identity state) scope token = do 363 found <- atomically (lookupResource identity scope token <$> readTVar state) 364 case found of 365 Left p -> pure (Left p) 366 Right (Resource _ backend _ _ _) | internal backend -> closeResourceWith True runtime scope token 367 _ -> pure (Left (problem "wrong-kind" "close")) 368 369 -- Register transient host-owned resources before use. Ordinary failures retain 370 -- primary diagnostics plus bounded cleanup detail; terminal faults leave cleanup 371 -- to lexical settlement. Allocation must itself be exception-safe until return. 372 withTemporary :: Runtime -> Scope -> String -> IO (a, IO ()) -> (a -> IO b) -> IO (Either Problem b) 373 withTemporary runtime scope op allocate use = mask $ \restore -> do 374 slot <- newIORef Nothing 375 acquired <- acquire runtime scope $ do 376 (value, done) <- allocate 377 writeIORef slot (Just value) 378 pure (Internal done) 379 case acquired of 380 Left p -> pure (Left p) 381 Right token -> do 382 Just value <- readIORef slot 383 result <- restore (withInternalResource runtime scope token op (use value)) 384 closed <- closeInternalResource runtime scope token 385 pure $ case (result,closed) of 386 (Right value, Right ()) -> Right value 387 (Right _, Left cleanup) -> Left cleanup 388 (Left primary, Right ()) -> Left primary 389 (Left primary, Left cleanup) -> Left primary { detail = take 240 (detail primary) ++ 390 "; cleanup: " ++ take 240 (category cleanup ++ ": " ++ detail cleanup) } 391 392 withAccess :: Access -> Runtime -> Scope -> Token -> String -> (Backend -> Bool) -> (Backend -> IO a) -> IO (Either Problem a) 393 withAccess access (Runtime identity state) current token op rightKind use = mask $ \restore -> do 394 lease <- atomically $ do 395 snapshot <- readTVar state 396 case lookupResource identity current token snapshot of 397 Left e -> pure (Left e) 398 Right resource@(Resource _ backend busy closing _) -> do 399 dead <- readTVar closing 400 occupied <- readTVar busy 401 if dead then pure (Left (problem "closed-handle" op)) 402 else if not (rightKind (usable backend)) then pure (Left (problem "wrong-kind" op)) 403 else if occupied .&. leaseBits access (usable backend) /= 0 then pure (Left (problem "busy" op)) 404 else writeTVar busy (occupied .|. leaseBits access (usable backend)) >> pure (Right resource) 405 case lease of 406 Left e -> pure (Left e) 407 Right (Resource _ backend busy _ _) -> do 408 result <- try (restore (use (usable backend))) `finally` atomically (modifyTVar' busy (.&. complement (leaseBits access (usable backend)))) 409 case result of 410 Right value -> pure (Right value) 411 Left (exception :: SomeException) 412 | Just (ResourceFault p) <- fromException exception -> pure (Left p) 413 | Just e <- fromException exception -> pure (Left (ioProblem op e)) 414 | otherwise -> throwIO exception 415 416 readSome :: Runtime -> Scope -> Token -> Int -> IO (Either Problem BS.ByteString) 417 readSome runtime scope token count 418 | count <= 0 || count > chunkLimit = pure (Left (problem "invalid-bound" "read")) 419 | otherwise = withReaderLease runtime scope token (\readBytes -> readBytes count) 420 421 -- Internal codec transport: retain one directional lease across an entire frame, 422 -- not one lease per chunk. Internal clients must not retain the supplied reader 423 -- beyond the callback; no such function is exposed through the source protocol. 424 withReaderLease :: Runtime -> Scope -> Token -> ((Int -> IO BS.ByteString) -> IO a) -> IO (Either Problem a) 425 withReaderLease runtime scope token use = withAccess ReadDirection runtime scope token "read" isReader $ \backend -> 426 let checked readBytes count = do 427 unless (count > 0 && count <= chunkLimit) (resourceFault (problem "invalid-bound" "read")) 428 bytes <- readBytes count 429 unless (BS.length bytes <= count) (ioError (userError "backend exceeded read bound")) 430 pure bytes 431 in case backend of 432 Duplex methods -> use (checked (duplexRead methods)) 433 Reader readBytes _ -> use (checked readBytes) 434 File methods | Just readBytes <- fileReadAction methods -> use (checked readBytes) 435 _ -> error "validated reader kind" 436 437 writeSome :: Runtime -> Scope -> Token -> BS.ByteString -> IO (Either Problem Int) 438 writeSome runtime scope token bytes 439 | BS.null bytes || BS.length bytes > chunkLimit = pure (Left (problem "invalid-bound" "write")) 440 | otherwise = withWriterLease runtime scope token (\writeBytes -> writeBytes bytes) 441 442 -- As for the reader hook, internal clients must not retain the supplied writer. 443 withWriterLease :: Runtime -> Scope -> Token -> ((BS.ByteString -> IO Int) -> IO a) -> IO (Either Problem a) 444 withWriterLease runtime scope token use = withAccess WriteDirection runtime scope token "write" isWriter $ \backend -> 445 let checked writeBytes bytes = do 446 unless (not (BS.null bytes) && BS.length bytes <= chunkLimit) 447 (resourceFault (problem "invalid-bound" "write")) 448 count <- writeBytes bytes 449 unless (count > 0 && count <= BS.length bytes) (ioError (userError "invalid backend write progress")) 450 pure count 451 in case backend of 452 Duplex methods -> use (checked (duplexWrite methods)) 453 File methods | Just writeBytes <- fileWriteAction methods -> use (checked writeBytes) 454 Writer writeBytes _ -> use (checked writeBytes) 455 Staged writeBytes _ _ _ -> use (checked writeBytes) 456 _ -> error "validated writer kind" 457 458 isReader, isWriter, isStage, isDigest :: Backend -> Bool 459 isReader (Duplex _) = True 460 isReader (File methods) = maybe False (const True) (fileReadAction methods) 461 isReader (Reader _ _) = True 462 isReader _ = False 463 isWriter (Duplex _) = True 464 isWriter (File methods) = maybe False (const True) (fileWriteAction methods) 465 isWriter (Writer _ _) = True 466 isWriter (Staged _ _ _ _) = True 467 isWriter _ = False 468 isStage (Staged _ _ _ _) = True 469 isStage _ = False 470 isDigest (Digest _ _ _) = True 471 isDigest _ = False 472 473 acceptConnection :: Runtime -> Scope -> Token -> Scope -> IO (Either Problem Token) 474 acceptConnection runtime current token owner = do 475 allowed <- isAncestor runtime current owner 476 if not allowed then pure (Left (problem "out-of-scope" "accept")) else do 477 result <- withLease runtime current token "accept" isListener $ \backend -> case backend of 478 Listener methods -> acquire runtime owner (listenerAccept methods) 479 _ -> error "validated listener kind" 480 pure (either Left id result) 481 where isListener (Listener _) = True 482 isListener _ = False 483 484 shutdownWrite :: Runtime -> Scope -> Token -> IO (Either Problem ()) 485 shutdownWrite runtime current token = withAccess WriteDirection runtime current token "shutdown-write" isDuplex $ \backend -> case backend of 486 Duplex methods -> duplexShutdownWrite methods 487 _ -> error "validated duplex kind" 488 where isDuplex (Duplex _) = True 489 isDuplex _ = False 490 491 socketAddress :: Runtime -> Scope -> Token -> Bool -> IO (Either Problem Endpoint) 492 socketAddress runtime current token peer = withLease runtime current token op supported $ \backend -> case backend of 493 Duplex methods -> (if peer then duplexPeer else duplexLocal) methods 494 Listener methods -> listenerLocal methods 495 _ -> error "validated socket kind" 496 where op = if peer then "peer-address" else "local-address" 497 supported (Duplex _) = True 498 supported (Listener _) = not peer 499 supported _ = False 500 501 nextDirectory :: Runtime -> Scope -> Token -> IO (Either Problem (Maybe String)) 502 nextDirectory runtime scope token = withLease runtime scope token "next" isDirectory $ \backend -> case backend of 503 Directory next _ -> next 504 _ -> error "validated directory kind" 505 where isDirectory (Directory _ _) = True 506 isDirectory _ = False 507 508 sealStage :: Runtime -> Scope -> Token -> IO (Either Problem ()) 509 sealStage runtime scope token = withLease runtime scope token "seal" isStage $ \backend -> case backend of 510 Staged _ seal _ _ -> seal 511 _ -> error "validated stage kind" 512 publishStage :: Runtime -> Scope -> Token -> Bool -> FilePath -> IO (Either Problem String) 513 publishStage runtime scope token replace destination = withLease runtime scope token "publish" isStage $ \backend -> case backend of 514 Staged _ _ publish _ -> publish replace destination 515 _ -> error "validated stage kind" 516 updateDigest :: Runtime -> Scope -> Token -> BS.ByteString -> IO (Either Problem ()) 517 updateDigest runtime scope token bytes 518 | BS.null bytes || BS.length bytes > chunkLimit = pure (Left (problem "invalid-bound" "digest-update")) 519 | otherwise = withLease runtime scope token "digest-update" isDigest $ \backend -> case backend of 520 Digest update _ _ -> update bytes 521 _ -> error "validated digest kind" 522 finishDigest :: Runtime -> Scope -> Token -> IO (Either Problem String) 523 finishDigest runtime scope token = withLease runtime scope token "digest-finish" isDigest $ \backend -> case backend of 524 Digest _ finish _ -> finish 525 _ -> error "validated digest kind" 526 527 -- The close gate serializes explicit close and teardown without holding the 528 -- registry lock during IO. Mark closing before waiting for leases. If interrupted 529 -- while waiting, a subsequent scope teardown can finish the close. 530 closeResource :: Runtime -> Scope -> Token -> IO (Either Problem ()) 531 closeResource = closeResourceWith False 532 533 -- Only lexical settlement may revoke inherited references, never the OS handles. 534 closeResourceWith :: Bool -> Runtime -> Scope -> Token -> IO (Either Problem ()) 535 closeResourceWith settling runtime@(Runtime identity state) current token = mask_ $ do 536 found <- atomically $ lookupResource identity current token <$> readTVar state 537 case found of 538 Left e -> pure (Left e) 539 Right (Resource _ backend _ _ _) | internal backend && not settling -> 540 pure (Left (problem "internal-resource" "close")) 541 Right (Resource _ backend _ _ _) | inherited backend && not settling -> 542 pure (Left (problem "borrowed-resource" "close")) 543 Right (Resource _ _ _ _ gate) -> withMVar gate $ \_ -> do 544 -- Claim closing in the SAME transaction as token validation. Otherwise a 545 -- transfer can rekey the entry between lookup and closeEntry, allowing an 546 -- old alias to close the new owner's backend and leave a dead live entry. 547 fresh <- atomically $ do 548 result <- lookupResource identity current token <$> readTVar state 549 case result of 550 Right (Resource _ _ _ closing _) -> writeTVar closing True 551 Left _ -> pure () 552 pure result 553 case fresh of 554 Left e -> pure (Left e) 555 Right resource -> closeEntry runtime token resource 556 557 closeEntry :: Runtime -> Token -> Resource -> IO (Either Problem ()) 558 closeEntry (Runtime _ state) (Token _ key) (Resource _ backend busy closing _) = do 559 atomically (writeTVar closing True) 560 atomically (readTVar busy >>= check . (== 0)) 561 result <- try (release backend) 562 case result of 563 Left (exception :: SomeException) | Just (_ :: SomeAsyncException) <- fromException exception -> throwIO exception 564 _ -> do 565 atomically $ modifyTVar' state $ \(State n scopes resources) -> State n scopes (M.delete key resources) 566 pure $ case result of 567 Right () -> Right () 568 Left exception -> Left $ case fromException exception of 569 Just e -> ioProblem "close" e 570 Nothing -> Problem "backend-fault" "close" (take 512 (displayException exception)) "unknown" 571 572 -- IO.Tasks must settle children before entering resource teardown. Close any 573 -- remaining nested resource scopes before this scope, in reverse acquisition order. 574 closeScope :: Runtime -> Scope -> IO [Problem] 575 closeScope runtime@(Runtime identity state) scope = mask_ $ do 576 atomically (beginCloseScopeSTM runtime scope) 577 children <- atomically $ do 578 State _ scopes _ <- readTVar state 579 case M.lookup scope scopes of 580 Just (ScopeState _ _ pending) -> check (pending == 0) 581 Nothing -> pure () 582 pure [key | (key, ScopeState parent _ _) <- M.toDescList scopes, parent == Just scope] 583 childErrors <- foldM (\errors child -> combineErrors errors <$> closeScope runtime child) [] children 584 keys <- atomically $ do 585 State _ _ resources <- readTVar state 586 pure [key | (key, Resource owner _ _ _ _) <- M.toDescList resources, owner == scope] 587 errors <- foldM (\previous key -> do 588 result <- closeResourceWith True runtime scope (Token identity key) 589 pure (combineErrors previous (either (:[]) (const []) result))) childErrors keys 590 atomically $ modifyTVar' state $ \(State n scopes resources) -> State n (M.delete scope scopes) resources 591 pure errors 592 593 -- Keep bounded diagnostics while preserving an explicit count of omissions. 594 combineErrors :: [Problem] -> [Problem] -> [Problem] 595 combineErrors left right = 596 let allErrors = left ++ right 597 actual = filter ((/= "cleanup-omitted") . category) allErrors 598 prior = sum [maybe 0 id (readMaybe (detail e) :: Maybe Integer) | e <- allErrors, category e == "cleanup-omitted"] 599 omitted = prior + toInteger (max 0 (length actual - 16)) 600 in take 16 actual ++ [Problem "cleanup-omitted" "close" (show omitted) "none" | omitted > 0] 601 602 liveCounts :: Runtime -> IO (Int, Int) 603 liveCounts (Runtime _ state) = atomically $ do 604 State _ scopes resources <- readTVar state 605 pure (M.size scopes, M.size resources) 606 607 runtimeIdentity :: Runtime -> IO Integer 608 runtimeIdentity (Runtime identity _) = pure identity 609 isAncestor :: Runtime -> Scope -> Scope -> IO Bool 610 isAncestor (Runtime _ state) current owner = atomically $ do 611 State _ scopes _ <- readTVar state 612 pure (inside current owner scopes)