commit dfd70d677a6c7ad941235a8ac4bb6199629ef5c1
parent 6b4aabd9ec87d203e2e56a97b2878115e2e68000
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 19:50:50 -0500
Resolve symlinked parents before authorizing new IO paths
Diffstat:
5 files changed, 73 insertions(+), 72 deletions(-)
diff --git a/docs/host-abi.md b/docs/host-abi.md
@@ -248,3 +248,14 @@ not normalize text or translate newlines; it performs no filesystem IO.
These actions support the current-source native compiler candidate. Retained
compiler bundles keep their recorded behavior until integrated publication.
+
+## Haskell filesystem permission boundary
+
+Read/write grants are canonical path prefixes with directory-component boundaries.
+Checks resolve existing symlinked ancestors even when the final filename does not
+yet exist. Empty grants do not authorize paths; resolution errors deny access.
+Unrestricted read/write flags explicitly bypass the corresponding checks.
+
+This is not a race-free filesystem sandbox: checking a pathname and subsequently
+opening it are separate operations. Use trusted directories and do not allow
+untrusted concurrent mutation of directory entries or symlinks.
diff --git a/src/IODriver.hs b/src/IODriver.hs
@@ -26,8 +26,8 @@ import qualified System.IO as IO
import Control.Exception (try, catch, bracket, evaluate, IOException, SomeException)
import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
import Data.List (isPrefixOf, isInfixOf)
-import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories, takeDirectory)
-import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory, listDirectory, createDirectory, renameFile, removeFile, doesDirectoryExist)
+import System.FilePath (addTrailingPathSeparator, takeDirectory)
+import System.Directory (canonicalizePath, doesPathExist, listDirectory, createDirectory, renameFile, removeFile, doesDirectoryExist)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Crypto.Hash (hash, SHA256, Digest)
import Data.ByteArray (convert)
@@ -1016,78 +1016,27 @@ stepMachine sockVar machine =
Left _ -> finishValue machine (errResult "invalid bytes")
Left _ -> finishValue machine (errResult "invalid string")
- -- Permission and IO helpers
- checkReadPerm p =
- if allowReadAll (rtPerms (machineRuntime machine))
- then return Nothing
- else do
- mp <- canonicalizeSafe p
- case mp of
- Left _ -> return $ Just policyErrResult
- Right path -> do
- allowed <- pathAllowed path (allowRead (rtPerms (machineRuntime machine)))
- if allowed
- then return Nothing
- else return $ Just policyErrResult
-
- checkWritePerm p =
- if allowWriteAll (rtPerms (machineRuntime machine))
- then return Nothing
- else do
- mp <- canonicalizeSafe p
- case mp of
- Left _ -> return $ Just policyErrResult
- Right path -> do
- allowed <- pathAllowed path (allowWrite (rtPerms (machineRuntime machine)))
- if allowed
- then return Nothing
- else return $ Just policyErrResult
+ -- Resolve existing symlinked ancestors even when the final name is new.
+ -- Canonicalization failures deny access; they must never fall back to a
+ -- syntactic prefix. This is a path policy, not a race-free filesystem sandbox.
+ checkReadPerm = checkPathPerm allowReadAll allowRead
+ checkWritePerm = checkPathPerm allowWriteAll allowWrite
+
+ checkPathPerm unrestricted roots path
+ | unrestricted perms = pure Nothing
+ | otherwise = do
+ checked <- try $ do
+ canonical <- canonicalizePath path
+ prefixes <- mapM canonicalizePath (filter (not . null) (roots perms))
+ pure (any (isPathPrefixOf canonical) prefixes)
+ pure $ case checked of
+ Right True -> Nothing
+ Right False -> Just policyErrResult
+ Left (_ :: IOException) -> Just policyErrResult
+ where perms = rtPerms (machineRuntime machine)
policyErrResult = errResult "permission denied"
- canonicalizeSafe :: FilePath -> IO (Either String FilePath)
- canonicalizeSafe p = do
- exists <- doesPathExist p
- if exists
- then do
- result <- try (canonicalizePath p) :: IO (Either SomeException FilePath)
- case result of
- Right canon -> return $ Right canon
- Left _ -> normalizeSyntactic p
- else normalizeSyntactic p
-
- normalizeSyntactic :: FilePath -> IO (Either String FilePath)
- normalizeSyntactic p = do
- absPath <- if isRelative p then (</> p) <$> getCurrentDirectory else return p
- let norm = normalise absPath
- dirs = splitDirectories norm
- if ".." `elem` dirs
- then return $ Left "Path contains unresolved parent-directory references"
- else return $ Right norm
-
- pathAllowed :: FilePath -> [FilePath] -> IO Bool
- pathAllowed _ [] = return False
- pathAllowed p prefixes = do
- let validPrefixes = filter (not . null) prefixes
- if null validPrefixes
- then return False
- else do
- absPrefixes <- mapM resolvePrefix validPrefixes
- return $ any (isPathPrefixOf p) absPrefixes
-
- resolvePrefix :: FilePath -> IO FilePath
- resolvePrefix p = do
- let norm = normalise p
- absPath <- if isRelative norm then (</> norm) <$> getCurrentDirectory else return norm
- exists <- doesPathExist absPath
- if exists
- then do
- result <- try (canonicalizePath absPath) :: IO (Either SomeException FilePath)
- case result of
- Right canon -> return canon
- Left _ -> return absPath
- else return absPath
-
isPathPrefixOf :: FilePath -> FilePath -> Bool
isPathPrefixOf path prefix =
let prefix' = addTrailingPathSeparator prefix
diff --git a/test/IOBoundaryTests.hs b/test/IOBoundaryTests.hs
@@ -0,0 +1,38 @@
+module IOBoundaryTests (ioBoundaryTests) where
+
+import IODriver
+import Runtime
+import qualified Data.ByteString as BS
+import System.Directory (createDirectory, createDirectoryLink, doesFileExist)
+import System.IO.Temp (withSystemTempDirectory)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+ioBoundaryTests :: TestTree
+ioBoundaryTests = testGroup "IO ownership and path boundaries"
+ [ testCase "new file through escaping parent symlink is denied" $
+ withSystemTempDirectory "io-path" $ \dir -> do
+ let allowed = dir ++ "/allowed"
+ outside = dir ++ "/outside"
+ target = allowed ++ "/link/new"
+ createDirectory allowed
+ createDirectory outside
+ createDirectoryLink outside (allowed ++ "/link")
+ reply <- runIO (IOPermissions [allowed] [allowed] False False)
+ (envelope (act 21 (Fork (ofString target) (ofString "escape"))))
+ reply @?= Right (Fork Leaf (Fork (ofString "permission denied") Leaf))
+ doesFileExist (outside ++ "/new") >>= (@?= False)
+ , testCase "new file below allowed parent still succeeds" $
+ withSystemTempDirectory "io-path" $ \dir -> do
+ let target = dir ++ "/new"
+ reply <- runIO (IOPermissions [dir] [dir] False False)
+ (envelope (act 21 (Fork (ofString target) (ofString "ok"))))
+ reply @?= Right (Fork (Stem Leaf) (Fork Leaf Leaf))
+ BS.readFile target >>= (@?= "ok")
+
+ ]
+
+act :: Integer -> T -> T
+act tag = Fork (ofNumber tag)
+envelope :: T -> T
+envelope action = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -1,5 +1,6 @@
module Main where
+import IOBoundaryTests (ioBoundaryTests)
import PortableCompilerTests (portableCompilerTests)
import ExecutableLoadingTests (executableLoadingTests)
import ScriptedEffects (runScriptedEffects)
@@ -57,7 +58,8 @@ main = do
tests :: TestTree
tests = testGroup "Tricu Tests"
- [ portableCompilerTests
+ [ ioBoundaryTests
+ , portableCompilerTests
, executableLoadingTests
, runtimePresentationTests
, interactionInspectionTests
diff --git a/tricu.cabal b/tricu.cabal
@@ -209,5 +209,6 @@ test-suite tricu-tests
ParserValueTests
PortableTestCompiler
IODriverTests
+ IOBoundaryTests
ScriptedEffects
ReferenceFixtures
