James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Explicit filesystem permissions required

Browse Source
This commit is contained in:
James Eversole
2026-05-12 19:02:51 -05:00
parent d6df01105c
commit 983a0cc5a7
5 changed files with 150 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files

27
README.md
View File

@@ -36,21 +36,22 @@ tricu < -- or calculate its size (/demos/size.tri)
tricu < size not?
tricu > 12
tricu < !help
tricu < !help
tricu version 1.1.0
Available commands:
!exit - Exit the REPL
!clear - Clear the screen
!reset - Reset preferences for selected versions
!help - Show tricu version and available commands
!output - Change output format (tree|fsl|ast|ternary|ascii|decode)
!definitions - List all defined terms in the content store
!import - Import definitions from file to the content store
!watch - Watch a file for changes, evaluate terms, and store them
!refresh - Refresh environment from content store (definitions are live)
!versions - Show all versions of a term by name
!select - Select a specific version of a term for subsequent lookups
!tag - Add or update a tag for a term by hash or name
!exit - Exit the REPL
!clear - Clear the screen
!reset - Reset preferences for selected versions
!help - Show tricu version and available commands
!output - Change output format (tree|fsl|ast|ternary|ascii|decode)
!definitions - List all defined terms in the content store
!import - Import definitions from file to the content store
!watch - Watch a file for changes, evaluate terms, and store them
!versions - Show all versions of a term by name
!select - Select a specific version of a term for subsequent lookups
!tag - Add or update a tag for a term by hash or name
!export - Export a term bundle to file (hash, file)
!bundleimport- Import a bundle file into the content store
```
## Installation and Use

112
src/IODriver.hs
View File

@@ -1,6 +1,7 @@
module IODriver
( IOPermissions(..)
, defaultPerms
, unsafePerms
, checkIOSentinel
, runIO
) where
@@ -8,19 +9,25 @@ module IODriver
import Research (T(..), apply, toString, toNumber, ofString, ofNumber)
import System.IO (putStr, getLine)
import qualified System.IO as IO
import Control.Exception (try, IOException)
import Control.Monad (unless)
import Control.Exception (try, IOException, SomeException)
import System.Exit (die)
import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
import Data.List (isPrefixOf)
import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories)
import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory)
data IOPermissions = IOPermissions
{ allowRead :: [FilePath]
, allowWrite :: [FilePath]
{ allowRead :: [FilePath]
, allowWrite :: [FilePath]
, allowReadAll :: Bool
, allowWriteAll :: Bool
}
defaultPerms :: IOPermissions
defaultPerms = IOPermissions [] []
defaultPerms = IOPermissions [] [] False False
unsafePerms :: IOPermissions
unsafePerms = IOPermissions [] [] True True
checkIOSentinel :: T -> Either String (Integer, T)
checkIOSentinel tree =
@@ -63,9 +70,12 @@ runIO perms actionTree = go actionTree
3 -> case payload of
Fork path k -> do
p <- decodeString path "ReadFile"
checkReadPerm p
content <- tryReadFile p
go (apply k content)
mDeny <- checkReadPerm p
case mDeny of
Just denied -> go (apply k denied)
Nothing -> do
content <- tryReadFile p
go (apply k content)
_ -> die "Invalid ReadFile payload: expected pair path continuation"
4 -> case payload of
@@ -73,9 +83,12 @@ runIO perms actionTree = go actionTree
Fork contents k -> do
p <- decodeString path "WriteFile"
c <- decodeString contents "WriteFile"
checkWritePerm p
res <- tryWriteFile p c
go (apply k res)
mDeny <- checkWritePerm p
case mDeny of
Just denied -> go (apply k denied)
Nothing -> do
res <- tryWriteFile p c
go (apply k res)
_ -> die "Invalid WriteFile payload: expected pair contents continuation"
_ -> die "Invalid WriteFile payload: expected pair path (pair contents continuation)"
@@ -87,15 +100,80 @@ runIO perms actionTree = go actionTree
Left err -> die $ "Invalid " ++ ctx ++ " string: " ++ err
checkReadPerm p =
unless (pathAllowed p (allowRead perms)) $
die $ "Permission denied: read not allowed for " ++ p
if allowReadAll perms
then return Nothing
else do
mp <- canonicalizeSafe p
case mp of
Left _ -> return $ Just policyErrResult
Right path -> do
allowed <- pathAllowed path (allowRead perms)
if allowed
then return Nothing
else return $ Just policyErrResult
checkWritePerm p =
unless (pathAllowed p (allowWrite perms)) $
die $ "Permission denied: write not allowed for " ++ p
if allowWriteAll perms
then return Nothing
else do
mp <- canonicalizeSafe p
case mp of
Left _ -> return $ Just policyErrResult
Right path -> do
allowed <- pathAllowed path (allowWrite perms)
if allowed
then return Nothing
else return $ Just policyErrResult
pathAllowed _ [] = True -- No restrictions
pathAllowed p prefixes = any (\prefix -> prefix `isPrefixOf` p) prefixes
policyErrResult = errResult 5
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
in path == prefix || prefix' `isPrefixOf` path
tryReadFile path = do
result <- try (IO.readFile path) :: IO (Either IOException String)

36
src/Main.hs
View File

@@ -33,13 +33,16 @@ import System.Environment (lookupEnv)
data TricuArgs
= Repl
| Eval
{ evalFiles :: [FilePath]
, evalFormat :: EvaluatedForm
, evalOutput :: FilePath
, evalDb :: Maybe FilePath
, evalIo :: Bool
, evalAllowRead :: [FilePath]
, evalAllowWrite :: [FilePath]
{ evalFiles :: [FilePath]
, evalFormat :: EvaluatedForm
, evalOutput :: FilePath
, evalDb :: Maybe FilePath
, evalIo :: Bool
, evalAllowRead :: [FilePath]
, evalAllowWrite :: [FilePath]
, evalAllowReadAll :: Bool
, evalAllowWriteAll :: Bool
, evalUnsafeIo :: Bool
}
| ArboricxCompile
{ compileInput :: FilePath
@@ -116,6 +119,18 @@ evalParser = Eval
<> metavar "PATH"
<> help "Allow writing to PATH prefix (repeatable)"
))
<*> switch
( long "allow-read-all"
<> help "Allow reading from any path"
)
<*> switch
( long "allow-write-all"
<> help "Allow writing to any path"
)
<*> switch
( long "unsafe-io"
<> help "Allow unrestricted read and write access"
)
compileParser :: Parser TricuArgs
compileParser = ArboricxCompile
@@ -294,7 +309,12 @@ runEval opts = do
finalT <- if evalIo opts
then case checkIOSentinel resultT of
Right (1, action) -> do
let perms = IOPermissions (evalAllowRead opts) (evalAllowWrite opts)
let perms = IOPermissions
{ allowRead = evalAllowRead opts
, allowWrite = evalAllowWrite opts
, allowReadAll = evalUnsafeIo opts || evalAllowReadAll opts
, allowWriteAll = evalUnsafeIo opts || evalAllowWriteAll opts
}
runIO perms action
Right (v, _) -> die $ "Unsupported IO ABI version: " ++ show v
Left err -> die $ "IO mode requested but " ++ err

14
src/Research.hs
View File

@@ -227,10 +227,18 @@ toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
Left err -> Left err
toNumber _ = Left "Invalid Tree Calculus number"
toChar :: Integer -> Either String Char
toChar n
| n < 0 = Left "Negative character code"
| n > 0x10FFFF = Left "Character code out of Unicode range"
| n >= 0xD800 && n <= 0xDFFF = Left "Surrogate character code not allowed"
| otherwise = Right (toEnum (fromInteger n))
toString :: T -> Either String String
toString tc = case toList tc of
Right list -> traverse (fmap (toEnum . fromInteger) . toNumber) list
Left _ -> Left "Invalid Tree Calculus string"
toString tc = do
list <- toList tc
nums <- mapM toNumber list
mapM toChar nums
toList :: T -> Either String [T]
toList Leaf = Right []

4
test/Spec.hs
View File

@@ -8,7 +8,7 @@ import REPL
import Research
import Wire
import ContentStore
import IODriver
import IODriver (IOPermissions(..), checkIOSentinel, runIO, unsafePerms)
import Control.Exception (evaluate, try, SomeException)
import Control.Monad (forM_)
@@ -1307,6 +1307,6 @@ runIOSource source = do
ioEnv <- evaluateFile "./lib/io.tri"
env <- evalTricuWithStore Nothing ioEnv (parseTricu source)
case checkIOSentinel (mainResult env) of
Right (1, action) -> runIO defaultPerms action
Right (1, action) -> runIO unsafePerms action
Right (v, _) -> assertFailure ("Unsupported IO ABI version: " ++ show v)
Left err -> assertFailure ("Expected IO sentinel: " ++ err)