diff --git a/gf.cabal b/gf.cabal
index deb64faa8..748066d31 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -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 = documentRootpath -- hmm, check for ".."
+translatePath path = documentRoot optionspath -- 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.
HTML
- Last modified: Tue Sep 27 15:41:36 CEST 2011
+ Last modified: Mon Oct 10 17:54:37 CEST 2011
About
+
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 = handleErrors . handleCGIErrors . cgiMain' "." "."
-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) []
+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 cache environ =
+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 = rootmakeRelative "/" (makeRelative root cwdpath)
+ 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(..),