commit d22a96741c772ee46d8ad7dcf621f7da9626d8bd
parent af1c5829148422d4424b010bcd33b68c075f168b
Author: James Eversole <james@eversole.co>
Date: Tue, 12 May 2026 19:02:51 -0500
Explicit filesystem permissions required
Diffstat:
5 files changed, 151 insertions(+), 44 deletions(-)
diff --git a/README.md b/README.md
@@ -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
diff --git a/src/IODriver.hs b/src/IODriver.hs
@@ -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
-
- pathAllowed _ [] = True -- No restrictions
- pathAllowed p prefixes = any (\prefix -> prefix `isPrefixOf` p) prefixes
+ 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
+
+ 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)
diff --git a/src/Main.hs b/src/Main.hs
@@ -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
diff --git a/src/Research.hs b/src/Research.hs
@@ -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 []
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -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)
