GF shell restricted mode

By setting the environment variable GF_RESTRICTED before starting GF, the shell
will be run in restricted mode. This will prevent the GF shell from starting
arbitrary system commands (most uses of System.Cmd.system are blocked) and
writing arbitrary files (most commands that use writeFile et al are blocked).

Restricted mode is intended minimize the potential security risks involved
in allowing public access to the GF shell over the internet. It should be used
in conjuction with system level protection mechanisms (e.g. file permissions)
to make sure that a publicly acessible GF shell does not give access to parts
of the system that should not be publicly accessible.

src/compiler/GF/Command/Commands.hs

@@ -45,7 +45,7 @@ import Data.Binary (encodeFile)
 import Data.List
 import Data.Maybe
 import qualified Data.Map as Map
-import System.Cmd
+--import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead!
 import Text.PrettyPrint
 import Data.List (sort)
 import Debug.Trace
@@ -172,8 +172,8 @@ allCommands env@(pgf, mos) = Map.fromList [
                  let view = optViewGraph opts
                  let format = optViewFormat opts 
                  writeUTF8File (file "dot") grph
-                 system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+                 restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
-                 system $ view ++ " " ++ file format
+                 restrictedSystem $ view ++ " " ++ file format
                  return void
                else return $ fromString grph,
      examples = [
@@ -769,9 +769,9 @@ allCommands env@(pgf, mos) = Map.fromList [
      exec = \opts arg -> do
        let tmpi = "_tmpi" ---
        let tmpo = "_tmpo"
-       writeFile tmpi $ toString arg
+       restricted $ writeFile tmpi $ toString arg
        let syst = optComm opts ++ " " ++ tmpi
-       system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo 
+       restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo 
        s <- readFile tmpo
        return $ fromString s,
      flags = [
@@ -843,9 +843,9 @@ allCommands env@(pgf, mos) = Map.fromList [
            let file s = "_grphd." ++ s
            let view = optViewGraph opts
            let format = optViewFormat opts 
-           writeUTF8File (file "dot") grphs
+           restricted $ writeUTF8File (file "dot") grphs
-           system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+           restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
-           system $ view ++ " " ++ file format
+           restrictedSystem $ view ++ " " ++ file format
            return void
           else return $ fromString grphs,
      examples = [
@@ -884,9 +884,9 @@ allCommands env@(pgf, mos) = Map.fromList [
            let file s = "_grph." ++ s
            let view = optViewGraph opts
            let format = optViewFormat opts 
-           writeUTF8File (file "dot") grph
+           restricted $ writeUTF8File (file "dot") grph
-           system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+           restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
-           system $ view ++ " " ++ file format
+           restrictedSystem $ view ++ " " ++ file format
            return void
           else return $ fromString grph,
      examples = [
@@ -929,9 +929,9 @@ allCommands env@(pgf, mos) = Map.fromList [
            let file s = "_grph." ++ s
            let view = optViewGraph opts
            let format = optViewFormat opts 
-           writeUTF8File (file "dot") grph
+           restricted $ writeUTF8File (file "dot") grph
-           system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+           restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
-           system $ view  ++ " " ++ file format
+           restrictedSystem $ view  ++ " " ++ file format
            return void
           else return $ fromString grph,
      examples = [
@@ -955,8 +955,8 @@ allCommands env@(pgf, mos) = Map.fromList [
      exec = \opts arg -> do
          let file = valStrOpts "file" "_gftmp" opts
          if isOpt "append" opts 
-           then appendFile file (toString arg)
+           then restricted $ appendFile file (toString arg)
-           else writeUTF8File file (toString arg)
+           else restricted $ writeUTF8File file (toString arg)
          return void,
      options = [
        ("append","append to file, instead of overwriting it")

src/compiler/GF/Infra/UseIO.hs

@@ -26,6 +26,7 @@ import System.IO.Error
 import System.Environment
 import System.Exit
 import System.CPUTime
+import System.Cmd
 import Text.Printf
 import Control.Monad
 import Control.Exception(evaluate)
@@ -191,3 +192,19 @@ writeUTF8File fpath content = do
   hSetEncoding h utf8
   hPutStr h content
   hClose h
+
+-- * Functions to limit acesss to arbitrary IO and system commands
+restricted io =
+    either (const io) (const $ fail message) =<< try (getEnv "GF_RESTRICTED")
+  where
+    message =
+      "This operation is not allowed when GF is running in restricted mode."
+
+restrictedSystem = restricted . system
+
+
+-- Because GHC adds the confusing text "user error" for failures cased by
+-- calls to fail.
+ioErrorText e = if isUserError e
+                then ioeGetErrorString e
+                else show e

src/compiler/GFI.hs

@@ -36,7 +36,6 @@ import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as BS
 import qualified Text.ParserCombinators.ReadP as RP
 import System.IO
-import System.Cmd
 import System.CPUTime
 import System.Directory
 import Control.Exception
@@ -107,7 +106,7 @@ loop opts gfenv0 = do
         r <- runInterruptibly $ case pwords of
 
           "!":ws -> do
-             system $ unwords ws
+             restrictedSystem $ unwords ws
              loopNewCPU gfenv
           "cc":ws -> do
              let
@@ -154,7 +153,7 @@ loop opts gfenv0 = do
              let stop = case ws of
                    ('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs
                    _ -> Nothing
-             writeFile "_gfdepgraph.dot" (depGraph stop sgr)
+             restricted $ writeFile "_gfdepgraph.dot" (depGraph stop sgr)
              putStrLn "wrote graph in file _gfdepgraph.dot"
              loopNewCPU gfenv
           "eh":w:_ -> do
@@ -220,9 +219,11 @@ loop opts gfenv0 = do
             interpretCommandLine env s0
             loopNewCPU gfenv
 --        gfenv' <- return $ either (const gfenv) id r
-        gfenv' <- either (\e -> (print e >> return gfenv)) return r
+        gfenv' <- either (\e -> (printException e >> return gfenv)) return r
         loop opts gfenv'
 
+printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
+
 checkComputeTerm sgr t = do
                  mo <- maybe (Bad "no source grammar in scope") return $ greatestResource sgr
                  ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t