From 983a0cc5a77e30e1972c4c700a5d10bfca05f425 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Tue, 12 May 2026 19:02:51 -0500 Subject: [PATCH] Explicit filesystem permissions required --- README.md | 27 ++++++------ src/IODriver.hs | 112 ++++++++++++++++++++++++++++++++++++++++-------- src/Main.hs | 36 ++++++++++++---- src/Research.hs | 14 ++++-- test/Spec.hs | 4 +- 5 files changed, 150 insertions(+), 43 deletions(-) diff --git a/README.md b/README.md index 2a5bba2..feda354 100644 --- 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 index 3695f1f..7838f5e 100644 --- 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 + 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) diff --git a/src/Main.hs b/src/Main.hs index 1567604..f91a74b 100644 --- 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 index c801486..35633b1 100644 --- 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 index 29dc5c6..b9cf67a 100644 --- 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)