diff options
| -rw-r--r-- | gf.cabal | 3 | ||||
| -rw-r--r-- | src/compiler/GF/Command/Commands.hs | 30 | ||||
| -rw-r--r-- | src/compiler/GF/Command/Interpreter.hs | 7 | ||||
| -rw-r--r-- | src/compiler/GF/Infra/UseIO.hs | 10 | ||||
| -rw-r--r-- | src/compiler/GFI.hs | 85 | ||||
| -rw-r--r-- | src/compiler/GFServer.hs | 7 |
6 files changed, 71 insertions, 71 deletions
@@ -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 diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index efa131636..53461669e 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/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 diff --git a/src/compiler/GF/Command/Interpreter.hs b/src/compiler/GF/Command/Interpreter.hs index 5758c24f4..dd5a05594 100644 --- a/src/compiler/GF/Command/Interpreter.hs +++ b/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) diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index a9b3cada2..9f2d27f3f 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/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 diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index 3fd751739..136f52972 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -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 diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index b17eed827..ae71b82b9 100644 --- a/src/compiler/GFServer.hs +++ b/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 |