More functionality in "gf -server" mode

"gf -server" mode now includes PGF service and the services to support
example-based grammar writing. (But gf -server is not quite ready to replace
pgf-http yet...) 

Also bumped GF version number to 3.2.10-darcs

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

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)
+                        setCurrentDirectory,getCurrentDirectory,
-import System.FilePath(takeExtension,(</>))
+                        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
+     cache <- PS.newPGFCache
-     initServer port (modifyMVar state . handle state0 execute1)
+     --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
+       logPutStrLn $ method++" "++upath++" "++show qs
-       case path of
+       case upath of
          "/new" -> new
 --       "/stop" ->
 --       "/start" ->
          "/gfshell" -> inDir qs $ look "command" . command
          "/upload" -> inDir qs upload
-         '/':rpath -> do resp <- serveStaticFile (translatePath rpath)
+         '/':rpath ->
-                         return (state,resp)
+           case (takeDirectory path,takeFileName path,takeExtension path) of
-         _ -> return (state,resp400 path)
+             (_  ,_             ,".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

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)

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

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);
+    var url=window.exb_url || "exb/exb.fcgi";
-    for(var arg in args) url+="&"+arg+"="+encodeURIComponent(args[arg]);
+    var q=""
-    http_get_json(url,cont)
+    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)
 	    }
 	}

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>

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 =
+cgiMain = handleErrors . handleCGIErrors . cgiMain' "." "."
-    handleErrors . handleCGIErrors $
-    do command <- getInp "command"
-       environ <- parseEnviron =<< getInp "state"
-       cgiMain' cache command environ
 
-cgiMain' cache command environ =
+cgiMain' root cwd cache =
-  case command of
+  do command <- getInp "command"
-    "possibilities" -> outputJSONP (E.getNext environ)
+     environ <- parseEnviron =<< getInp "state"
-    "provide_example" ->  doProvideExample cache environ
+     case command of
-    "abstract_example" -> doAbstractExample cache environ
+       "possibilities" -> outputJSONP (E.getNext environ)
-    "test_function" -> doTestFunction cache environ
+       "provide_example" ->  doProvideExample root cwd cache environ
-    _ -> throwCGIError 400 ("Unknown command: "++command) []
+       "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
+     parsePGF <- readParsePGF cwd cache
-     pgf <- liftIO . readCache cache =<< getInp "grammar"
+     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

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

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(..),