Explicit filesystem permissions required

README.md

@@ -39,18 +39,19 @@ tricu > 12
 tricu < !help
 tricu version 1.1.0
 Available commands:
-    !exit        - Exit the REPL
+  !exit        - Exit the REPL
-    !clear       - Clear the screen
+  !clear       - Clear the screen
-    !reset       - Reset preferences for selected versions
+  !reset       - Reset preferences for selected versions
-    !help        - Show tricu version and available commands
+  !help        - Show tricu version and available commands
-    !output      - Change output format (tree|fsl|ast|ternary|ascii|decode)
+  !output      - Change output format (tree|fsl|ast|ternary|ascii|decode)
-    !definitions - List all defined terms in the content store
+  !definitions - List all defined terms in the content store
-    !import      - Import definitions from file to the content store
+  !import      - Import definitions from file to the content store
-    !watch       - Watch a file for changes, evaluate terms, and store them
+  !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
-    !versions    - Show all versions of a term by name
+  !select      - Select a specific version of a term for subsequent lookups
-    !select      - Select a specific version of a term for subsequent lookups
+  !tag         - Add or update a tag for a term by hash or name
-    !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

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.Exception (try, IOException, SomeException)
-import Control.Monad (unless)
 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]
+  { allowRead     :: [FilePath]
-  , allowWrite :: [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
+          mDeny <- checkReadPerm p
-          content <- tryReadFile p
+          case mDeny of
-          go (apply k content)
+            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
+            mDeny <- checkWritePerm p
-            res <- tryWriteFile p c
+            case mDeny of
-            go (apply k res)
+              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)) $
+      if allowReadAll perms
-        die $ "Permission denied: read not allowed for " ++ p
+        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)) $
+      if allowWriteAll perms
-        die $ "Permission denied: write not allowed for " ++ p
+        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
+    policyErrResult = errResult 5
-    pathAllowed p prefixes = any (\prefix -> prefix `isPrefixOf` p) prefixes
+
+    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)

src/Main.hs

@@ -33,13 +33,16 @@ import System.Environment (lookupEnv)
 data TricuArgs
   = Repl
   | Eval
-      { evalFiles      :: [FilePath]
+      { evalFiles         :: [FilePath]
-      , evalFormat     :: EvaluatedForm
+      , evalFormat        :: EvaluatedForm
-      , evalOutput     :: FilePath
+      , evalOutput        :: FilePath
-      , evalDb         :: Maybe FilePath
+      , evalDb            :: Maybe FilePath
-      , evalIo         :: Bool
+      , evalIo            :: Bool
-      , evalAllowRead  :: [FilePath]
+      , evalAllowRead     :: [FilePath]
-      , evalAllowWrite :: [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

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
+toString tc = do
-  Right list -> traverse (fmap (toEnum . fromInteger) . toNumber) list
+  list <- toList tc
-  Left _ -> Left "Invalid Tree Calculus string"
+  nums <- mapM toNumber list
+  mapM toChar nums
 
 toList :: T -> Either String [T]
 toList Leaf = Right []

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)