From 0a27aaf1e6823ea2c81f91265e97d98d2d20d9ea Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 13 Apr 2011 14:58:01 +0000 Subject: [PATCH] Added a preliminary "gf -server" mode. The command "gf -server" now starts a simple HTTP server on port 41295, providing a simple web API to the GF compiler. It currently support the follwing operations: * creating new temporary directories for grammar uploads, * uploading grammars files for use in the GF shell, * executing GF shell commands, and * accessing static files. This means that GF now depends on some additional networking related packages, but they should be available and easy to install on all platforms. There is also a new configuration flag "server" in gf.cabal, so GF will be compiled without support for server mode if the extra packages are unavailable. Note that running gf -server while connected to the internet can be a security risk. To prevent unauthorized access to the rest of the system, it is advisable to run the server in GF_RESTRICTED mode and as a user with suitably restricted file permissions. --- gf.cabal | 8 ++ src/compiler/GF.hs | 2 +- src/compiler/GF/Infra/Option.hs | 2 + src/compiler/GFI.hs | 20 ++++- src/compiler/GFServer.hs | 148 ++++++++++++++++++++++++++++++++ 5 files changed, 175 insertions(+), 5 deletions(-) create mode 100644 src/compiler/GFServer.hs diff --git a/gf.cabal b/gf.cabal index acd1ac2e3..6a5a27441 100644 --- a/gf.cabal +++ b/gf.cabal @@ -19,6 +19,10 @@ flag interrupt Description: Enable Ctrl+Break in the shell Default: True +flag server + Description: Include --server mode + Default: True + library build-depends: base >= 4.2 && <5, array, @@ -82,6 +86,10 @@ executable gf pretty, mtl, haskeline + if flag(server) + build-depends: httpd-shed, network, silently, utf8-string + cpp-options: -DSERVER_MODE + other-modules: GFServer build-tools: happy, alex if os(windows) build-depends: Win32 diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index 503253589..43a2a0b7f 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -45,5 +45,5 @@ mainOpts opts files = ModeHelp -> putStrLn helpMessage ModeInteractive -> mainGFI opts files ModeRun -> mainRunGFI opts files + ModeServer -> mainServerGFI opts files ModeCompiler -> dieIOE (mainGFC opts files) - diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 9c8925f3d..1560f315f 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -74,6 +74,7 @@ errors = fail . unlines -- Types data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler + | ModeServer deriving (Show,Eq,Ord) data Verbosity = Quiet | Normal | Verbose | Debug @@ -293,6 +294,7 @@ optDescr = Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.", Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", + Option [] ["server"] (NoArg (mode ModeServer)) "Run in HTTP server mode.", Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .", diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index 8d89f146c..bec2e3b0e 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, CPP #-} -module GFI (mainGFI,mainRunGFI) where +module GFI (mainGFI,mainRunGFI,mainServerGFI) where import GF.Command.Interpreter import GF.Command.Importing @@ -44,6 +44,9 @@ import Control.Monad import Data.Version import Text.PrettyPrint (render) import GF.System.Signal +#ifdef SERVER_MODE +import GFServer(server) +#endif --import System.IO.Error (try) #ifdef mingw32_HOST_OS import System.Win32.Console @@ -53,9 +56,9 @@ import System.Win32.NLS import Paths_gf mainRunGFI :: Options -> [FilePath] -> IO () -mainRunGFI opts files = do - let opts1 = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) opts - shell opts1 files +mainRunGFI opts files = shell (beQuiet opts) files + +beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) mainGFI :: Options -> [FilePath] -> IO () mainGFI opts files = do @@ -64,6 +67,15 @@ mainGFI opts files = do shell opts files = loop opts =<< importInEnv emptyGFEnv opts files +#ifdef SERVER_MODE +mainServerGFI opts0 files = + server (execute1 opts) =<< importInEnv emptyGFEnv opts files + where opts = beQuiet opts0 +#else +mainServerGFI opts files = + error "GF has not been compiled with server mode support" +#endif + -- | Read end execute commands until it is time to quit loop :: Options -> GFEnv -> IO () loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs new file mode 100644 index 000000000..75ff7bd3d --- /dev/null +++ b/src/compiler/GFServer.hs @@ -0,0 +1,148 @@ +module GFServer(server) where +import Data.List(partition) +import qualified Data.Map as M +import Control.Monad(when) +import System.Random(randomRIO) +import System.IO(stdout,stderr) +import System.IO.Error(try,ioError) +import System.Directory(doesDirectoryExist,doesFileExist,createDirectory, + setCurrentDirectory,getCurrentDirectory) +import System.FilePath(takeExtension,()) +import Control.Concurrent.MVar(newMVar,modifyMVar) +import Network.URI(URI(..)) +import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments, + noCache) +import System.IO.Silently(hCapture) +import Codec.Binary.UTF8.String(encodeString) +import GF.Infra.UseIO(readBinaryFile) + +-- * Configuraiton +port = 41295 +documentRoot = "." + +-- * HTTP server +server execute1 state0 = + do state <- newMVar M.empty + putStrLn $ "Starting server on port "++show port + initServer port (modifyMVar state . handle state0 execute1) + +-- * HTTP request handler +handle state0 execute1 (Request method URI{uriPath=path,uriQuery=q} hdrs body) state = + do let qs = decodeQ $ + case method of + "GET" -> queryToArguments q + "POST" -> queryToArguments body + + logPutStrLn $ method++" "++path++" "++show qs + case path of + "/new" -> new +-- "/stop" -> +-- "/start" -> + "/gfshell" -> inDir qs $ look "command" . command + "/upload" -> inDir qs upload + '/':rpath -> do resp <- serveStaticFile (translatePath rpath) + return (state,resp) + _ -> return (state,resp400 path) + where + look field ok qs = + case partition ((==field).fst) qs of + ((_,value):qs1,qs2) -> ok value (qs1++qs2) + _ -> bad + where + bad = return (state,resp400 $ "no "++field++" in request") + + inDir qs ok = look "dir" cd qs + where + cd ('/':dir@('t':'m':'p':_)) qs' = + do cwd <- getCurrentDirectory + b <- try $ setCurrentDirectory dir + case b of + Left _ -> return (state,resp404 dir) + Right _ -> do logPutStrLn $ "cd "++dir + r <- try (ok dir qs') + setCurrentDirectory cwd + either ioError return r + cd dir _ = return (state,resp400 $ "unacceptable directory "++dir) + + new = + do dir <- newDirectory + return (state,ok200 dir) + + command dir cmd _ = + do let st = maybe state0 id $ M.lookup dir state + (output,st') <- hCapture [stdout,stderr] (execute1 st cmd) + let state' = maybe state (flip (M.insert dir) state) st' + return (state',ok200 output) + + upload dir files= + do let update (name,contents)= updateFile (name++".gf") contents + mapM_ update files + return (state,resp204) + +-- * Static content + +translatePath path = documentRootpath -- hmm, check for ".." + +serveStaticFile path = + do b <- doesDirectoryExist path + let path' = if b then path "index.html" else path + serveStaticFile' path' + +serveStaticFile' path = + do b <- doesFileExist path + let (t,rdFile,encode) = contentTypeFromExt (takeExtension path) + if b then fmap (ok200' (ct t) . encode) $ rdFile path + else return (resp404 path) + +-- * Logging +logPutStrLn = putStrLn + +-- * Standard HTTP responses +ok200 body = Response 200 [plainUTF8,noCache] (encodeString body) +ok200' t body = Response 200 [t] body +resp204 = Response 204 [] "" -- no content +resp400 msg = Response 400 [plain] $ "Bad request: "++msg++"\n" +resp404 path = Response 404 [plain] $ "Not found: "++path++"\n" + +-- * Content types +plain = ct "text/plain" +plainUTF8 = ct "text/plain; charset=UTF-8" +ct t = ("Content-Type",t) + +contentTypeFromExt ext = + case ext of + ".html" -> text "html" + ".htm" -> text "html" + ".xml" -> text "xml" + ".txt" -> text "plain" + ".css" -> text "css" + ".js" -> text "javascript" + ".png" -> bin "image/png" + ".jpg" -> bin "image/jpg" + _ -> bin "application/octet-stream" + where + text subtype = ("text/"++subtype++"; charset=UTF-8",readFile,encodeString) + bin t = (t,readBinaryFile,id) + +-- * IO utilities +updateFile path new = + do old <- try $ readFile path + when (Right new/=old) $ do logPutStrLn $ "Updating "++path + seq (either (const 0) length old) $ + writeFile path new + + +newDirectory = + do k <- randomRIO (1,maxBound::Int) + let path = "tmp/gfse."++show k + b <- try $ createDirectory path + case b of + Left _ -> newDirectory + Right _ -> return ('/':path) + +-- * misc utils + +decodeQ qs = [(decode n,decode v)|(n,v)<-qs] +decode = map decode1 +decode1 '+' = ' ' -- httpd-shed bug workaround +decode1 c = c