Explicit filesystem permissions required

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)