Use the SIO monad in the GF shell

+ The restrictions on arbitrary IO when GF is running in restricted mode is now
  enforced in the types.
+ This hopefully also solves an intermittent problem when accessing the GF
  shell through the web API provided by gf -server. This was visible in the
  Simple Translation Tool and probably caused by some low-level bug in the
  GHC IO libraries.

gf.cabal

@@ -112,7 +112,8 @@ executable gf
                  parallel
   ghc-options: -threaded
   if flag(server)
-    build-depends: httpd-shed, network, silently, utf8-string, json, cgi
+    build-depends: httpd-shed, network, utf8-string, json, cgi
+                   -- ,silently
     cpp-options: -DSERVER_MODE
     other-modules: GFServer
     hs-source-dirs: src/server src/server/transfer src/example-based

src/compiler/GF/Command/Commands.hs

@@ -10,6 +10,7 @@ module GF.Command.Commands (
   CommandInfo,
   CommandOutput
   ) where
+import Prelude hiding (putStrLn)
 
 import PGF
 import PGF.CId
@@ -27,7 +28,8 @@ import GF.Compile.Export
 import GF.Compile.ToAPI
 import GF.Compile.ExampleBased
 import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl)
-import GF.Infra.UseIO
+import GF.Infra.UseIO(writeUTF8File)
+import GF.Infra.SIO
 import GF.Data.ErrM ----
 import GF.Command.Abstract
 import GF.Command.Messages
@@ -48,12 +50,12 @@ import qualified Data.Map as Map
 import Text.PrettyPrint
 import Data.List (sort)
 import Debug.Trace
-import System.Random (newStdGen) ----
+--import System.Random (newStdGen) ----
 
 type CommandOutput = ([Expr],String) ---- errors, etc
 
 data CommandInfo = CommandInfo {
-  exec     :: PGFEnv -> [Option] -> [Expr] -> IO CommandOutput,
+  exec     :: PGFEnv -> [Option] -> [Expr] -> SIO CommandOutput,
   synopsis :: String,
   syntax   :: String,
   explanation :: String,
@@ -350,7 +352,7 @@ allCommands = Map.fromList [
        pgf <- optProbs opts pgf
        let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
        let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
-       (file',ws) <- parseExamplesInGrammar conf file
+       (file',ws) <- restricted $ parseExamplesInGrammar conf file
        if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
        return (fromString ("wrote " ++ file')),
      needsTypeCheck = False
@@ -544,7 +546,7 @@ allCommands = Map.fromList [
          let typ  = optType pgf opts
          pgf <- optProbs opts pgf
          let mt = mexp xs
-         morphologyQuiz mt pgf lang typ
+         restricted $ morphologyQuiz mt pgf lang typ
          return void,
      flags = [
        ("lang","language of the quiz"),
@@ -721,7 +723,7 @@ allCommands = Map.fromList [
                                   (es, err) | null es   -> return ([], render (err $$ text "no trees found"))
                                             | otherwise -> return (es, render err)
 
-       s <- readFile file
+       s <- restricted $ readFile file
        case opts of
          _ | isOpt "lines" opts && isOpt "tree" opts ->
                returnFromLines (zip [1..] (lines s))
@@ -768,7 +770,7 @@ allCommands = Map.fromList [
          let typ  = optType pgf opts
          let mt   = mexp xs
          pgf <- optProbs opts pgf
-         translationQuiz mt pgf from to typ
+         restricted $ translationQuiz mt pgf from to typ
          return void,
      flags = [
        ("from","translate from this language"),
@@ -824,7 +826,7 @@ allCommands = Map.fromList [
        restricted $ writeFile tmpi $ toString arg
        let syst = optComm opts ++ " " ++ tmpi
        restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
-       s <- readFile tmpo
+       s <- restricted $ readFile tmpo
        return $ fromString s,
      flags = [
        ("command","the system command applied to the argument")
@@ -911,7 +913,7 @@ allCommands = Map.fromList [
          let outp = valStrOpts "output" "dot" opts
          mlab <- case file of
            "" -> return Nothing
-           _  -> readFile file >>= return . Just . getDepLabels . lines
+           _  -> restricted (readFile file) >>= return . Just . getDepLabels . lines
          let lang = optLang pgf opts
          let grphs = unlines $ map (graphvizDependencyTree outp debug mlab Nothing pgf lang) es
          if isFlag "view" opts || isFlag "format" opts then do
@@ -1172,16 +1174,16 @@ allCommands = Map.fromList [
    optProbs opts pgf = case valStrOpts "probs" "" opts of
      ""   -> return pgf
      file -> do
-       probs <- readProbabilitiesFromFile file pgf
+       probs <- restricted $ readProbabilitiesFromFile file pgf
        return (setProbabilities probs pgf)
 
    optTranslit opts = case (valStrOpts "to" "" opts, valStrOpts "from" "" opts) of
      ("","")  -> return id
      (file,"") -> do
-       src <- readFile file
+       src <- restricted $ readFile file
        return $ transliterateWithFile file src False
      (_,file) -> do
-       src <- readFile file
+       src <- restricted $ readFile file
        return $ transliterateWithFile file src True
 
    optFile opts = valStrOpts "file" "_gftmp" opts
@@ -1230,7 +1232,7 @@ allCommands = Map.fromList [
      | isOpt "pgf"      opts = do
           let pgf1 = if isOpt "opt" opts then optimizePGF pgf else pgf
           let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts
-          encodeFile outfile pgf1
+          restricted $ encodeFile outfile pgf1
           putStrLn $ "wrote file " ++ outfile
           return void
      | isOpt "cats"     opts = return $ fromString $ unwords $ map showCId $ categories pgf
@@ -1345,7 +1347,7 @@ prMorphoAnalysis (w,lps) =
 
 
 -- This function is to be excuted when the command 'tok' is parsed
-execToktok :: PGFEnv -> [Option] -> [Expr] -> IO CommandOutput
+execToktok :: Monad m => PGFEnv -> [Option] -> [Expr] -> m CommandOutput
 execToktok (pgf, _) opts exprs = do
   let tokenizers = Map.fromList [ (l, mkTokenizer pgf l) | l <- languages pgf]
   case getLang opts of

src/compiler/GF/Command/Interpreter.hs

@@ -6,6 +6,7 @@ module GF.Command.Interpreter (
   interpretPipe,
   getCommandOp
   ) where
+import Prelude hiding (putStrLn)
 
 import GF.Command.Commands
 import GF.Command.Abstract
@@ -14,7 +15,7 @@ import PGF
 import PGF.Data
 import PGF.Morphology
 import GF.System.Signal
-import GF.Infra.UseIO
+import GF.Infra.SIO
 import GF.Infra.Option
 
 import Text.PrettyPrint
@@ -38,7 +39,7 @@ mkCommandEnv pgf =
 emptyCommandEnv :: CommandEnv
 emptyCommandEnv = mkCommandEnv emptyPGF
 
-interpretCommandLine :: CommandEnv -> String -> IO ()
+interpretCommandLine :: CommandEnv -> String -> SIO ()
 interpretCommandLine env line =
   case readCommandLine line of
     Just []    -> return ()
@@ -82,7 +83,7 @@ appCommand xs c@(Command i os arg) = case arg of
     EFun x     -> EFun x
 
 -- return the trees to be sent in pipe, and the output possibly printed
-interpret :: CommandEnv -> [Expr] -> Command -> IO CommandOutput
+interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
 interpret env trees comm = 
   case getCommand env trees comm of
     Left  msg               -> do putStrLn ('\n':msg)

src/compiler/GF/Infra/UseIO.hs

@@ -197,16 +197,6 @@ writeUTF8File fpath content = do
 readBinaryFile path = hGetContents =<< openBinaryFile path ReadMode
 writeBinaryFile path s = withBinaryFile path WriteMode (flip hPutStr s)
 
--- * 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

src/compiler/GFI.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE ScopedTypeVariables, CPP #-}
+-- | GF interactive mode
 module GFI (mainGFI,mainRunGFI,mainServerGFI) where
-
+import Prelude hiding (putStrLn,print)
-import GF.Command.Interpreter
+import qualified Prelude as P(putStrLn)
-import GF.Command.Importing
+import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandEnv,interpretCommandLine)
-import GF.Command.Commands
+--import GF.Command.Importing(importSource,importGrammar)
+import GF.Command.Commands(flags,options)
 import GF.Command.Abstract
-import GF.Command.Parse
+import GF.Command.Parse(readCommandLine,pCommand)
 import GF.Data.ErrM
 import GF.Data.Operations (chunks,err)
 import GF.Grammar hiding (Ident)
@@ -14,19 +16,19 @@ import GF.Grammar.Parser (runP, pExp)
 import GF.Grammar.Printer (ppGrammar, ppModule)
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
-import GF.Compile.Rename
+import GF.Compile.Rename(renameSourceTerm)
 import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError)
 import GF.Compile.TypeCheck.Concrete (inferLType,ppType)
-import GF.Infra.Dependencies
+import GF.Infra.Dependencies(depGraph)
 import GF.Infra.CheckM
-import GF.Infra.UseIO
+import GF.Infra.UseIO(ioErrorText)
+import GF.Infra.SIO
 import GF.Infra.Option
 import GF.Infra.Ident (showIdent)
-import GF.Infra.BuildInfo (buildInfo)
 import qualified System.Console.Haskeline as Haskeline
-import GF.Text.Coding
+import GF.Text.Coding(decodeUnicode,encodeUnicode)
 
-import GF.Compile.Coding
+import GF.Compile.Coding(codeTerm)
 
 import PGF
 import PGF.Data
@@ -38,14 +40,13 @@ import Data.List(nub,isPrefixOf,isInfixOf,partition)
 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.IO(utf8,mkTextEncoding,hSetEncoding,stdin,stdout,stderr)
-import System.CPUTime
+--import System.CPUTime(getCPUTime)
-import System.Directory
+import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
-import Control.Exception
+import Control.Exception(SomeException,fromException,evaluate,try)
 import Control.Monad
-import Data.Version
 import Text.PrettyPrint (render)
-import GF.System.Signal
+import qualified GF.System.Signal as IO(runInterruptibly)
 #ifdef SERVER_MODE
 import GFServer(server)
 #endif
@@ -54,7 +55,9 @@ import System.Win32.Console
 import System.Win32.NLS
 #endif
 
-import Paths_gf
+import GF.Infra.BuildInfo(buildInfo)
+import Data.Version(showVersion)
+import Paths_gf(version)
 
 mainRunGFI :: Options -> [FilePath] -> IO ()
 mainRunGFI opts files = shell (beQuiet opts) files
@@ -63,14 +66,14 @@ beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
 
 mainGFI :: Options -> [FilePath] -> IO ()
 mainGFI opts files = do
-  putStrLn welcome
+  P.putStrLn welcome
   shell opts files
 
-shell opts files = loop opts =<< importInEnv emptyGFEnv opts files
+shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files)
 
 #ifdef SERVER_MODE
 mainServerGFI opts0 port files =
-    server port (execute1 opts) =<< importInEnv emptyGFEnv opts files
+    server port (execute1 opts) =<< runSIO (importInEnv emptyGFEnv opts files)
   where opts = beQuiet opts0
 #else
 mainServerGFI opts files =
@@ -84,7 +87,8 @@ loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv
 -- | Read and execute one command, returning Just an updated environment for
 -- | the next command, or Nothing when it is time to quit
 readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv)
-readAndExecute1 opts gfenv = execute1 opts gfenv =<< readCommand opts gfenv
+readAndExecute1 opts gfenv =
+    runSIO . execute1 opts gfenv =<< readCommand opts gfenv
 
 -- | Read a command
 readCommand :: Options -> GFEnv -> IO String
@@ -94,7 +98,7 @@ readCommand opts gfenv0 =
       _       -> fetchCommand gfenv0
 
 -- | Optionally show how much CPU time was used to run an IO action
-optionallyShowCPUTime :: Options -> IO a -> IO a
+optionallyShowCPUTime :: Options -> SIO a -> SIO a
 optionallyShowCPUTime opts act 
   | not (verbAtLeast opts Normal) = act
   | otherwise = do t0 <- getCPUTime
@@ -115,7 +119,7 @@ loopOptNewCPU opts gfenv'
 
 -- | Execute a given command, returning Just an updated environment for
 -- | the next command, or Nothing when it is time to quit
-execute1 :: Options -> GFEnv -> String -> IO (Maybe GFEnv)
+execute1 :: Options -> GFEnv -> String -> SIO (Maybe GFEnv)
 execute1 opts gfenv0 s0 =
   interruptible $ optionallyShowCPUTime opts $
   case pwords s0 of
@@ -239,7 +243,7 @@ execute1 opts gfenv0 s0 =
                  [showIdent j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
         _ | elem "-save" os -> mapM_ 
                  (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in 
-                    writeFile file (render (ppModule Qualified m)) >> putStrLn ("wrote " ++ file))
+                    restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file))
                  (modules mygr)  
         _ -> putStrLn $ render $ ppGrammar mygr
       continue gfenv
@@ -253,7 +257,7 @@ execute1 opts gfenv0 s0 =
          continue gfenv
 
     eh [w] = -- Ehhh? Reads commands from a file, but does not execute them
-      do cs <- readFile w >>= return . map (interpretCommandLine env) . lines
+      do cs <- restricted (readFile w) >>= return . map (interpretCommandLine env) . lines
          continue gfenv
     eh _   = do putStrLn "eh command not parsed"
                 continue gfenv
@@ -311,20 +315,21 @@ execute1 opts gfenv0 s0 =
 
     set_encoding [c] =
       do let cod = renameEncoding c
+         restricted $ do
 #ifdef mingw32_HOST_OS
-         case cod of
+           case cod of
-           'C':'P':c -> case reads c of
+             'C':'P':c -> case reads c of
-                          [(cp,"")] -> do setConsoleCP cp
+                            [(cp,"")] -> do setConsoleCP cp
-                                          setConsoleOutputCP cp
+                                            setConsoleOutputCP cp
-                          _         -> return ()
+                            _         -> return ()
-           "UTF-8"   -> do setConsoleCP 65001
+             "UTF-8"   -> do setConsoleCP 65001
-                           setConsoleOutputCP 65001
+                             setConsoleOutputCP 65001
-           _         -> return ()
+             _         -> return ()
 #endif
-         enc <- mkTextEncoding cod
+           enc <- mkTextEncoding cod
-         hSetEncoding stdin  enc
+           hSetEncoding stdin  enc
-         hSetEncoding stdout enc
+           hSetEncoding stdout enc
-         hSetEncoding stderr enc
+           hSetEncoding stderr enc
          continue gfenv
     set_encoding _ = putStrLn "se command not parsed" >> continue gfenv
 
@@ -347,13 +352,13 @@ fetchCommand gfenv = do
           Haskeline.historyFile = Just path,
           Haskeline.autoAddHistory = True
         }
-  res <- runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt (commandenv gfenv)))
+  res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt (commandenv gfenv)))
   case res of
     Left  _        -> return ""
     Right Nothing  -> return "q"
     Right (Just s) -> return s
 
-importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
+importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv
 importInEnv gfenv opts files
     | flag optRetainResource opts =
         do src <- importSource (sourcegrammar gfenv) opts files

src/compiler/GFServer.hs

@@ -27,11 +27,12 @@ import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments,
 import Network.CGI(handleErrors,liftIO)
 import FastCGIUtils(outputJSONP,handleCGIErrors,stderrToFile)
 import Text.JSON(encode,showJSON,makeObj)
-import System.IO.Silently(hCapture)
+--import System.IO.Silently(hCapture)
 import System.Process(readProcessWithExitCode)
 import System.Exit(ExitCode(..))
 import Codec.Binary.UTF8.String(decodeString,encodeString)
 import GF.Infra.UseIO(readBinaryFile,writeBinaryFile)
+import GF.Infra.SIO(captureSIO)
 import qualified PGFService as PS
 import qualified ExampleService as ES
 import Data.Version(showVersion)
@@ -171,7 +172,7 @@ handle state0 cache execute1
                             case b of
                               Left _ -> err $ resp404 dir
                               Right dir' -> cd dir'
-               Right _ -> do logPutStrLn $ "cd "++dir
+               Right _ -> do --logPutStrLn $ "cd "++dir
                              r <- hmtry (ok dir)
                              liftIO $ setCurrentDirectory cwd
                              either (either (liftIO . ioError) err) return r
@@ -183,7 +184,7 @@ handle state0 cache execute1
       do cmd <- look "command"
          state <- get_state
          let st = maybe state0 id $ M.lookup dir state
-         (output,st') <- liftIO $ hCapture [stdout,stderr] (execute1 st cmd)
+         (output,st') <- liftIO $ captureSIO $ execute1 st cmd
          let state' = maybe state (flip (M.insert dir) state) st'
          put_state state'
          return $ ok200 output