msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Use the SIO monad in the GF shell

Browse Source 
+ 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.
This commit is contained in:
hallgren
2012-09-25 19:08:33 +00:00
parent ad536c1369
commit 7c65cd4073
6 changed files with 71 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
gf.cabal
View File

@@ -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

30
src/compiler/GF/Command/Commands.hs
View File

@@ -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

7
src/compiler/GF/Command/Interpreter.hs
View File

@@ -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)

10
src/compiler/GF/Infra/UseIO.hs
View File

@@ -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

85
src/compiler/GFI.hs
View File

@@ -1,11 +1,13 @@
{-# LANGUAGE ScopedTypeVariables, CPP #-}
-- | GF interactive mode
module GFI (mainGFI,mainRunGFI,mainServerGFI) where
import GF.Command.Interpreter
import GF.Command.Importing
import GF.Command.Commands
import Prelude hiding (putStrLn,print)
import qualified Prelude as P(putStrLn)
import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandEnv,interpretCommandLine)
--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.CPUTime
import System.Directory
import Control.Exception
import System.IO(utf8,mkTextEncoding,hSetEncoding,stdin,stdout,stderr)
--import System.CPUTime(getCPUTime)
import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
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
'C':'P':c -> case reads c of
[(cp,"")] -> do setConsoleCP cp
setConsoleOutputCP cp
_ -> return ()
"UTF-8" -> do setConsoleCP 65001
setConsoleOutputCP 65001
_ -> return ()
case cod of
'C':'P':c -> case reads c of
[(cp,"")] -> do setConsoleCP cp
setConsoleOutputCP cp
_ -> return ()
"UTF-8" -> do setConsoleCP 65001
setConsoleOutputCP 65001
_ -> return ()
#endif
enc <- mkTextEncoding cod
hSetEncoding stdin enc
hSetEncoding stdout enc
hSetEncoding stderr enc
enc <- mkTextEncoding cod
hSetEncoding stdin enc
hSetEncoding stdout 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

7
src/compiler/GFServer.hs
View File

@@ -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