commit cf86986b87cc51a5eac459f46e06ec14200f11c7
parent 02d44b105f80ed095fb1582fca963c1e7fef9f6b
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 20:23:36 -0500
Consolidate filesystem dispatch while preserving validation demand
Diffstat:
3 files changed, 70 insertions(+), 70 deletions(-)
diff --git a/docs/validation.md b/docs/validation.md
@@ -108,6 +108,19 @@ python3 test/portable_cli.py result/bin/tricu \
These checks do not regenerate the compiler or publish fixtures.
+### IO permissions and run lifetime
+
+The default `IO ownership and path boundaries` tests exercise new-file writes
+through escaping parent symlinks, ordinary allowed writes, and CAS rejection
+without forcing unpublished trees. Listening-socket rebinding checks run after
+normal completion, abort and timeout; blocked accept is also cancelled. FIFO
+writers establish that asynchronous OS work has started, stop draining until the
+run ends, then verify that the writer cannot finish its payload after run exit.
+These are resource/effect observations, not just scheduler-state assertions.
+
+See [the host ABI](host-abi.md.html#haskell-io-run-ownership) for cancellation
+semantics and the limits of path-based permissions and timeout enforcement.
+
### Current-source IO dependencies
```sh
diff --git a/src/IODriver.hs b/src/IODriver.hs
@@ -15,8 +15,8 @@ module IODriver
import Runtime (T(..), EvaluatedForm(Decode), formatT, apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes, ofList)
import ContentStore.Arboricx (treeTermDomain, decodeTreeTermShared, encodeTreeTerm)
-import ContentStore.Object (hashObject)
-import ContentStore.Bundle (indexedTreeDomain, decodeIndexedTree, encodeIndexedTree)
+import ContentStore.Object (hashObject, validateObjectHash)
+import ContentStore.Indexed (indexedTreeDomain, decodeIndexedTree, encodeIndexedTree)
import qualified Data.ByteString as BS
import System.IO (putStr, getLine)
import System.Posix.Files (createLink)
@@ -624,14 +624,7 @@ stepMachine sockVar machine =
AGetLine ->
pure (AsyncAction (ofString <$> getLine) machine)
- AReadSourceFile path ->
- case decodeString path "ReadSourceFile" of
- Right p -> do
- mDeny <- checkReadPerm p
- case mDeny of
- Just denied -> finishValue machine denied
- Nothing -> pure (AsyncAction (tryReadSourceFile p) machine)
- Left _ -> finishValue machine (errResult "invalid string")
+ AReadSourceFile path -> dispatchFileRead tryReadSourceFile path
AEncodeSourceText text ->
case decodeString text "EncodeSourceText" of
@@ -639,25 +632,10 @@ stepMachine sockVar machine =
(okResult (ofBytes (encodeUtf8 (T.pack contents))))
_ -> finishValue machine (errResult "invalid source scalar list")
- AReadFile path ->
- case decodeString path "ReadFile" of
- Right p -> do
- mDeny <- checkReadPerm p
- case mDeny of
- Just denied -> finishValue machine denied
- Nothing -> pure (AsyncAction (tryReadFile p) machine)
- Left _ -> finishValue machine (errResult "invalid string")
+ AReadFile path -> dispatchFileRead tryReadFile path
AReadTreeTerm path expected ->
- case (decodeString path "ReadTreeTerm", decodeString expected "ReadTreeTerm digest") of
- (Right p, Right digest)
- | length digest == 64 && all (`elem` ("0123456789abcdef" :: String)) digest -> do
- mDeny <- checkReadPerm p
- case mDeny of
- Just denied -> finishValue machine denied
- Nothing -> pure (AsyncAction (tryReadTreeTerm p (T.pack digest)) machine)
- | otherwise -> finishValue machine (errResult "invalid CAS digest")
- _ -> finishValue machine (errResult "invalid string")
+ dispatchTreeRead tryReadTreeTerm path expected
AHashTreeTerm tree ->
pure (AsyncAction (do
@@ -665,29 +643,10 @@ stepMachine sockVar machine =
return (okResult (ofString (T.unpack digest)))) machine)
AWriteTreeTermIfAbsent path expected tree ->
- case (decodeString path "WriteTreeTermIfAbsent", decodeString expected "tree-term digest") of
- (Right p, Right digest)
- | length digest == 64 && all (`elem` ("0123456789abcdef" :: String)) digest -> do
- -- Verifying a pre-existing/racing winner needs read permission.
- mWriteDeny <- checkWritePerm p
- mReadDeny <- checkReadPerm p
- case (mWriteDeny, mReadDeny) of
- (Just denied, _) -> finishValue machine denied
- (_, Just denied) -> finishValue machine denied
- _ -> pure (AsyncAction (tryWriteTreeTerm p (T.pack digest) tree) machine)
- | otherwise -> finishValue machine (errResult "invalid CAS digest")
- _ -> finishValue machine (errResult "invalid string")
+ dispatchTreeWrite tryWriteTreeTerm path expected tree
AReadIndexedTree path expected ->
- case (decodeString path "ReadIndexedTree", decodeString expected "ReadIndexedTree digest") of
- (Right p, Right digest)
- | length digest == 64 && all (`elem` ("0123456789abcdef" :: String)) digest -> do
- mDeny <- checkReadPerm p
- case mDeny of
- Just denied -> finishValue machine denied
- Nothing -> pure (AsyncAction (tryReadIndexedTree p (T.pack digest)) machine)
- | otherwise -> finishValue machine (errResult "invalid CAS digest")
- _ -> finishValue machine (errResult "invalid string")
+ dispatchTreeRead tryReadIndexedTree path expected
AHashIndexedTree tree ->
pure (AsyncAction (do
@@ -696,18 +655,7 @@ stepMachine sockVar machine =
return (okResult (ofString (T.unpack digest)))) machine)
AWriteIndexedTreeIfAbsent path expected tree ->
- case (decodeString path "WriteIndexedTreeIfAbsent", decodeString expected "indexed-tree digest") of
- (Right p, Right digest)
- | length digest == 64 && all (`elem` ("0123456789abcdef" :: String)) digest -> do
- -- Verifying a pre-existing/racing winner needs read permission.
- mWriteDeny <- checkWritePerm p
- mReadDeny <- checkReadPerm p
- case (mWriteDeny, mReadDeny) of
- (Just denied, _) -> finishValue machine denied
- (_, Just denied) -> finishValue machine denied
- _ -> pure (AsyncAction (tryWriteIndexedTree p (T.pack digest) tree) machine)
- | otherwise -> finishValue machine (errResult "invalid CAS digest")
- _ -> finishValue machine (errResult "invalid string")
+ dispatchTreeWrite tryWriteIndexedTree path expected tree
AWriteFile path contents ->
case decodeString path "WriteFile" of
@@ -1031,6 +979,38 @@ stepMachine sockVar machine =
return (okResult (ofNumber (fromIntegral sent)))
) machine)
+ dispatchFileRead reader path =
+ case toString path of
+ Left _ -> finishValue machine (errResult "invalid string")
+ Right p -> permittedRead reader p
+
+ permittedRead reader path = do
+ denied <- checkReadPerm path
+ case denied of
+ Just result -> finishValue machine result
+ Nothing -> pure (AsyncAction (reader path) machine)
+
+ -- Keep validation before permissions, and permissions before encoding or OS
+ -- work. In particular, denied tree publication must not force the tree.
+ withTreeIdentity path expected next =
+ case (toString path, toString expected) of
+ (Right p, Right digest) -> case validateObjectHash (T.pack digest) of
+ Left _ -> finishValue machine (errResult "invalid CAS digest")
+ Right () -> next p (T.pack digest)
+ _ -> finishValue machine (errResult "invalid string")
+
+ dispatchTreeRead reader path expected = withTreeIdentity path expected $ \p digest ->
+ permittedRead (\file -> reader file digest) p
+
+ dispatchTreeWrite writer path expected tree = withTreeIdentity path expected $ \p digest -> do
+ -- Verifying a pre-existing/racing winner requires read permission too.
+ writeDenied <- checkWritePerm p
+ readDenied <- checkReadPerm p
+ case (writeDenied, readDenied) of
+ (Just result, _) -> finishValue machine result
+ (_, Just result) -> finishValue machine result
+ _ -> pure (AsyncAction (writer p digest tree) machine)
+
dispatchAtomicBytes pathTree contentsTree exclusive =
case decodeString pathTree "AtomicWriteBytes" of
Right p ->
@@ -1127,17 +1107,12 @@ stepMachine sockVar machine =
| otherwise -> return $ errResult "CAS object exists with different bytes"
_ -> return published
- tryWriteFile path contents = do
- result <- try (IO.writeFile path contents) :: IO (Either IOException ())
- case result of
- Right () -> return $ okResult Leaf
- Left e -> return $ errResult (ioErrorString e)
+ tryWriteFile path contents = tryWriteUnit (IO.writeFile path contents)
+ tryWriteFileBytes path contents = tryWriteUnit (BS.writeFile path contents)
- tryWriteFileBytes path contents = do
- result <- try (BS.writeFile path contents) :: IO (Either IOException ())
- case result of
- Right () -> return $ okResult Leaf
- Left e -> return $ errResult (ioErrorString e)
+ tryWriteUnit action = do
+ result <- try action :: IO (Either IOException ())
+ pure $ either (errResult . ioErrorString) (const (okResult Leaf)) result
-- Sync file contents before exposing the name and its parent directory
-- after publication. A losing writer also syncs the winning object so a
diff --git a/test/IOBoundaryTests.hs b/test/IOBoundaryTests.hs
@@ -3,6 +3,7 @@ module IOBoundaryTests (ioBoundaryTests) where
import IODriver
import Runtime
import Control.Exception (bracket, try, IOException)
+import Control.Monad (forM_)
import Control.Concurrent (threadDelay)
import System.Posix.Files (createNamedPipe)
import System.Posix.IO (openFd, closeFd, defaultFileFlags, OpenMode(ReadOnly), OpenFileFlags(..), fdRead)
@@ -36,6 +37,17 @@ ioBoundaryTests = testGroup "IO ownership and path boundaries"
(envelope (act 21 (Fork (ofString target) (ofString "ok"))))
reply @?= Right (Fork (Stem Leaf) (Fork Leaf Leaf))
BS.readFile target >>= (@?= "ok")
+ , testCase "CAS validation and permission denial do not force publication trees" $
+ forM_ [36, 52] $ \tag -> do
+ let tree = error "denied tree was forced"
+ request path pin = envelope (act tag (Fork path (Fork pin tree)))
+ denied message = Right (Fork Leaf (Fork (ofString message) Leaf))
+ runIO defaultPerms (request (ofString "/denied") (ofString (replicate 64 '0')))
+ >>= (@?= denied "permission denied")
+ runIO defaultPerms (request (ofString "/denied") (ofString "BAD"))
+ >>= (@?= denied "invalid CAS digest")
+ runIO defaultPerms (request (Stem Leaf) (error "unused digest was forced"))
+ >>= (@?= denied "invalid string")
, testCase "root completion closes unclosed listening sockets" $ socketExit (act 0 Leaf) (Just (Right Leaf))
, testCase "abort closes unclosed listening sockets" $ socketExit (act 2 (ofString "stop")) (Just (Left "execution aborted: stop"))
, testCase "timeout closes unclosed listening sockets" $ socketExit (act 63 (ofNumber 60000)) Nothing
