diff options
| -rw-r--r-- | gf.cabal | 9 | ||||
| -rw-r--r-- | src/compiler/GFServer.hs | 54 | ||||
| -rw-r--r-- | src/editor/simple/cloud.js | 2 | ||||
| -rw-r--r-- | src/editor/simple/cloud2.js | 2 | ||||
| -rw-r--r-- | src/editor/simple/example_based.js | 10 | ||||
| -rw-r--r-- | src/editor/simple/index.html | 3 | ||||
| -rw-r--r-- | src/example-based/ExampleService.hs | 46 | ||||
| -rw-r--r-- | src/example-based/gf-exb.cabal | 2 | ||||
| -rw-r--r-- | src/server/RunHTTP.hs | 2 |
9 files changed, 83 insertions, 47 deletions
@@ -1,5 +1,5 @@ name: gf -version: 3.2.9 +version: 3.2.10-darcs cabal-version: >= 1.8 build-type: Custom @@ -93,14 +93,19 @@ executable gf mtl, haskeline if flag(server) - build-depends: httpd-shed, network, silently, utf8-string + build-depends: httpd-shed, network, silently, utf8-string, json, cgi cpp-options: -DSERVER_MODE other-modules: GFServer + hs-source-dirs: src/server src/server/transfer src/example-based + build-tools: happy, alex>=2 && <3 if os(windows) build-depends: Win32 else build-depends: unix + + ghc-prof-options: -auto-all + ghc-options: -O2 if impl(ghc>=7.0) ghc-options: -rtsopts diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index 75ff7bd3d..834e3f808 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -6,44 +6,67 @@ 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,(</>)) + setCurrentDirectory,getCurrentDirectory, + getDirectoryContents) +import System.FilePath(takeExtension,takeFileName,takeDirectory,(</>)) import Control.Concurrent.MVar(newMVar,modifyMVar) import Network.URI(URI(..)) import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments, noCache) +import Network.CGI(handleErrors,liftIO) +import FastCGIUtils(outputJSONP,handleCGIErrors) import System.IO.Silently(hCapture) import Codec.Binary.UTF8.String(encodeString) import GF.Infra.UseIO(readBinaryFile) +import qualified PGFService as PS +import qualified ExampleService as ES +import Paths_gf(getDataDir) +import RunHTTP(Options(..),cgiHandler) -- * Configuraiton -port = 41295 -documentRoot = "." + +options = Options { documentRoot = "." {-datadir</>"www"-}, port = gfport } +gfport = 41296 -- * HTTP server server execute1 state0 = do state <- newMVar M.empty - putStrLn $ "Starting server on port "++show port - initServer port (modifyMVar state . handle state0 execute1) + cache <- PS.newPGFCache + --datadir <- getDataDir + putStrLn $ "Starting server on port "++show gfport + initServer gfport (modifyMVar state . handle state0 cache execute1) -- * HTTP request handler -handle state0 execute1 (Request method URI{uriPath=path,uriQuery=q} hdrs body) state = +handle state0 cache execute1 + rq@(Request method URI{uriPath=upath,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 + logPutStrLn $ method++" "++upath++" "++show qs + case upath 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) + '/':rpath -> + case (takeDirectory path,takeFileName path,takeExtension path) of + (_ ,_ ,".pgf") -> wrapCGI $ PS.cgiMain' cache path + (dir,"grammars.cgi",_ ) -> wrapCGI $ grammarList dir + (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir cache + _ -> do resp <- serveStaticFile path + return (state,resp) + where path = translatePath rpath + _ -> return (state,resp400 upath) where + root = documentRoot options + + wrapCGI cgi = + do resp <- cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq + return (state,resp) + look field ok qs = case partition ((==field).fst) qs of ((_,value):qs1,qs2) -> ok value (qs1++qs2) @@ -79,9 +102,14 @@ handle state0 execute1 (Request method URI{uriPath=path,uriQuery=q} hdrs body) s mapM_ update files return (state,resp204) + grammarList dir = + do paths <- liftIO $ getDirectoryContents dir + let pgfs = [path|path<-paths, takeExtension path==".pgf"] + outputJSONP pgfs + -- * Static content -translatePath path = documentRoot</>path -- hmm, check for ".." +translatePath path = documentRoot options</>path -- hmm, check for ".." serveStaticFile path = do b <- doesDirectoryExist path diff --git a/src/editor/simple/cloud.js b/src/editor/simple/cloud.js index fad66e1ff..44b7d8157 100644 --- a/src/editor/simple/cloud.js +++ b/src/editor/simple/cloud.js @@ -137,7 +137,7 @@ function gfshell(cmd,cont) { // Check the syntax of an expression function check_exp(s,cont) { function check(gf_message) { - debug("cc "+s+" = "+gf_message); + //debug("cc "+s+" = "+gf_message); cont(/parse error/.test(gf_message) ? "parse error" : null); } if(navigator.onLine) diff --git a/src/editor/simple/cloud2.js b/src/editor/simple/cloud2.js index 2331b39f2..c57922438 100644 --- a/src/editor/simple/cloud2.js +++ b/src/editor/simple/cloud2.js @@ -63,7 +63,7 @@ function gfshell(cmd,cont) { // Check the syntax of an expression function check_exp(s,cont) { function check(gf_message) { - debug("cc "+s+" = "+gf_message); + //debug("cc "+s+" = "+gf_message); cont(/parse error/.test(gf_message) ? "parse error" : null); } gfshell("cc "+s,check); diff --git a/src/editor/simple/example_based.js b/src/editor/simple/example_based.js index 83fde0f6c..1fb13740a 100644 --- a/src/editor/simple/example_based.js +++ b/src/editor/simple/example_based.js @@ -31,9 +31,11 @@ function exb_state(g,ci) { } function exb_call(g,ci,command,args,cont) { - var url="exb/exb.fcgi?command="+command+"&state="+exb_state(g,ci); - for(var arg in args) url+="&"+arg+"="+encodeURIComponent(args[arg]); - http_get_json(url,cont) + var url=window.exb_url || "exb/exb.fcgi"; + var q="" + for(var arg in args) q+="&"+arg+"="+encodeURIComponent(args[arg]); + var cmd="?command="+command+"&state="+encodeURIComponent(exb_state(g,ci))+q; + http_get_json(url+cmd,cont) } function ask_possibilities(g,ci) { @@ -126,7 +128,7 @@ function exb_linbuttons(g,ci,f) { exb_call(g,ci,"provide_example", {lang:g.basename+conc.example_lang, fun:fun, - grammar:"."+dir+"/"+g.basename+".pgf"}, + grammar:dir+"/"+g.basename+".pgf"}, show_example) } } diff --git a/src/editor/simple/index.html b/src/editor/simple/index.html index de5efa373..27b053300 100644 --- a/src/editor/simple/index.html +++ b/src/editor/simple/index.html @@ -32,10 +32,11 @@ This page does not work without JavaScript. <hr> <div class=modtime><small> HTML -<!-- hhmts start --> Last modified: Tue Sep 27 15:41:36 CEST 2011 <!-- hhmts end --> +<!-- hhmts start --> Last modified: Mon Oct 10 17:54:37 CEST 2011 <!-- hhmts end --> </small></div> <a href="about.html">About</a> <pre id=debug></pre> +<script type="text/javascript" src="config.js"></script> <!-- optional --> <script type="text/javascript" src="support.js"></script> <script type="text/javascript" src="localstorage.js"></script> <script type="text/javascript" src="gf_abs.js"></script> diff --git a/src/example-based/ExampleService.hs b/src/example-based/ExampleService.hs index 165caccba..e4198a87b 100644 --- a/src/example-based/ExampleService.hs +++ b/src/example-based/ExampleService.hs @@ -1,4 +1,5 @@ -module ExampleService(cgiMain,newPGFCache) where +module ExampleService(cgiMain,cgiMain',newPGFCache) where +import System.FilePath((</>),makeRelative) import Data.Map(fromList) import Data.Char(isDigit) import Data.Maybe(fromJust) @@ -14,31 +15,30 @@ newPGFCache = newCache readPGF cgiMain :: Cache PGF -> CGI CGIResult -cgiMain cache = - handleErrors . handleCGIErrors $ - do command <- getInp "command" - environ <- parseEnviron =<< getInp "state" - cgiMain' cache command environ - -cgiMain' cache command environ = - case command of - "possibilities" -> outputJSONP (E.getNext environ) - "provide_example" -> doProvideExample cache environ - "abstract_example" -> doAbstractExample cache environ - "test_function" -> doTestFunction cache environ - _ -> throwCGIError 400 ("Unknown command: "++command) [] - -doProvideExample cache environ = +cgiMain = handleErrors . handleCGIErrors . cgiMain' "." "." + +cgiMain' root cwd cache = + do command <- getInp "command" + environ <- parseEnviron =<< getInp "state" + case command of + "possibilities" -> outputJSONP (E.getNext environ) + "provide_example" -> doProvideExample root cwd cache environ + "abstract_example" -> doAbstractExample cwd cache environ + "test_function" -> doTestFunction cwd cache environ + _ -> throwCGIError 400 ("Unknown command: "++command) [] + +doProvideExample root cwd cache environ = do Just lang <- readInput "lang" fun <- getCId "fun" - parsePGF <- readParsePGF cache - pgf <- liftIO . readCache cache =<< getInp "grammar" + parsePGF <- readParsePGF cwd cache + let adjpath path = root</>makeRelative "/" (makeRelative root cwd</>path) + pgf <- liftIO . readCache cache . adjpath =<< getInp "grammar" let Just (e,s) = E.provideExample environ fun parsePGF pgf lang res = (showExpr [] e,s) liftIO $ logError $ "proveExample ... = "++show res outputJSONP res -doAbstractExample cache environ = +doAbstractExample cwd cache environ = do example <- getInp "input" Just params <- readInput "params" absstr <- getInp "abstract" @@ -46,7 +46,7 @@ doAbstractExample cache environ = liftIO $ logError $ "abstract = "++showExpr [] abs Just cat <- readInput "cat" let t = mkType [] cat [] - parsePGF <- readParsePGF cache + parsePGF <- readParsePGF cwd cache let lang:_ = languages parsePGF ae <- liftIO $ abstractExample parsePGF environ lang t abs example outputJSONP (fmap (\(e,_)->(exprToAPI (instExpMeta params e),e)) ae) @@ -54,9 +54,9 @@ doAbstractExample cache environ = abstractExample parsePGF env lang cat abs example = E.searchGoodTree env abs (parse parsePGF lang cat example) -doTestFunction cache environ = +doTestFunction cwd cache environ = do fun <- getCId "fun" - parsePGF <- readParsePGF cache + parsePGF <- readParsePGF cwd cache let lang:_ = languages parsePGF Just txt <- return (E.testThis environ fun parsePGF lang) outputJSONP txt @@ -70,7 +70,7 @@ getLimit = maybe err return =<< readInput "limit" where err = throwCGIError 400 "Missing/bad limit" [] -readParsePGF cache = liftIO $ readCache cache "ParseEngAbs.pgf" +readParsePGF cwd cache = liftIO $ readCache cache (cwd</>"ParseEngAbs.pgf") parseEnviron s = do state <- liftIO $ readIO s return $ environ state diff --git a/src/example-based/gf-exb.cabal b/src/example-based/gf-exb.cabal index 75b1a49a1..1366e75da 100644 --- a/src/example-based/gf-exb.cabal +++ b/src/example-based/gf-exb.cabal @@ -17,7 +17,7 @@ executable exb.fcgi build-depends: base >=4.2 && <5, json, cgi, fastcgi, random, containers, old-time, directory, bytestring, utf8-string, - pretty, array, mtl, fst + pretty, array, mtl, fst, filepath if os(windows) ghc-options: -optl-mwindows diff --git a/src/server/RunHTTP.hs b/src/server/RunHTTP.hs index 0047d68a3..2afc92afc 100644 --- a/src/server/RunHTTP.hs +++ b/src/server/RunHTTP.hs @@ -1,4 +1,4 @@ -module RunHTTP(runHTTP,Options(..)) where +module RunHTTP(runHTTP,Options(..),cgiHandler) where import Network.URI(uriPath,uriQuery) import Network.CGI(ContentType(..)) import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..), |