From 0aba45560d2033c37c3d2e876e6f3ef89e1554d6 Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 11 Oct 2011 19:17:47 +0000 Subject: More work on support for gfse in "gf -server" mode --- src/compiler/GFServer.hs | 58 ++++++++++++++++++++++++++++++++++++++++----- src/editor/simple/cloud2.js | 10 ++++---- 2 files changed, 56 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index a7335279e..6e9b26a8d 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -18,8 +18,10 @@ import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments, import Network.CGI(handleErrors,liftIO) import FastCGIUtils(outputJSONP,handleCGIErrors) import System.IO.Silently(hCapture) +import System.Process(readProcessWithExitCode) +import System.Exit(ExitCode(..)) import Codec.Binary.UTF8.String(encodeString) -import GF.Infra.UseIO(readBinaryFile) +import GF.Infra.UseIO(readBinaryFile,writeBinaryFile) import qualified PGFService as PS import qualified ExampleService as ES import Paths_gf(getDataDir) @@ -101,6 +103,7 @@ handle state0 cache execute1 cloud dir cmd qs = case cmd of + "make" -> make dir qs "upload" -> upload qs "ls" -> jsonList "rm" -> look "file" rm qs @@ -108,8 +111,15 @@ handle state0 cache execute1 "link_directories" -> look "newdir" (link_directories dir) qs _ -> return (state,resp400 $ "cloud command "++cmd) + make dir files = + do (state,_) <- upload files + let args = "-s":"-make":map fst files + cmd = unwords ("gf":args) + out <- readProcessWithExitCode "gf" args "" + return (state,html200 (resultpage ('/':dir++"/") cmd out files)) + upload files = - do let update (name,contents)= updateFile (name++".gf") contents + do let update (name,contents)= updateFile name contents mapM_ update files return (state,resp204) @@ -145,6 +155,40 @@ handle state0 cache execute1 do paths <- getDirectoryContents dir return [path | path<-paths, takeExtension path==ext] +-- * Dynamic content + +resultpage dir cmd (ecode,stdout,stderr) files = + unlines $ + "": + "Uploaded": + "": + "

Uploaded

": + "
":escape cmd:"":escape stderr:escape stdout:
+    "
": + (if ecode==ExitSuccess + then "

OK

":links + else "

Error

":listing) + where + links = "
": + ("
▸ Minibar"): + "
◂ Back to Editor": + "
": + [] + + listing = concatMap listfile files + + listfile (name,source) = + ("

"++name++"

"):number source:"
":[] + + number = unlines . zipWith num [1..] . lines + num n s = pad (show n)++" "++escape s + pad s = replicate (5-length s) ' '++s + +escape = concatMap escape1 +escape1 '<' = "<" +escape1 '&' = "&" +escape1 c = [c] + -- * Static content translatePath path = documentRoot optionspath -- hmm, check for ".." @@ -167,8 +211,9 @@ serveStaticFile' path = logPutStrLn = putStrLn -- * Standard HTTP responses -ok200 body = Response 200 [plainUTF8,noCache] (encodeString body) -ok200' t body = Response 200 [t] body +ok200 = Response 200 [plainUTF8,noCache] . encodeString +ok200' t = Response 200 [t] +html200 = ok200' htmlUTF8 . encodeString resp204 = Response 204 [] "" -- no content resp400 msg = Response 400 [plain] $ "Bad request: "++msg++"\n" resp404 path = Response 404 [plain] $ "Not found: "++path++"\n" @@ -176,6 +221,7 @@ resp404 path = Response 404 [plain] $ "Not found: "++path++"\n" -- * Content types plain = ct "text/plain" plainUTF8 = ct "text/plain; charset=UTF-8" +htmlUTF8 = ct "text/html; charset=UTF-8" ct t = ("Content-Type",t) contentTypeFromExt ext = @@ -195,10 +241,10 @@ contentTypeFromExt ext = -- * IO utilities updateFile path new = - do old <- try $ readFile path + do old <- try $ readBinaryFile path when (Right new/=old) $ do logPutStrLn $ "Updating "++path seq (either (const 0) length old) $ - writeFile path new + writeBinaryFile path new newDirectory = diff --git a/src/editor/simple/cloud2.js b/src/editor/simple/cloud2.js index 38210a6f6..e32749dc1 100644 --- a/src/editor/simple/cloud2.js +++ b/src/editor/simple/cloud2.js @@ -21,20 +21,18 @@ function remove_cloud_grammar(g) { function upload(g) { function upload2(dir) { var form=node("form",{method:"post",action:"/cloud"}, - [hidden("dir",dir),hidden("command","upload"), - hidden(g.basename,show_abstract(g))]) + [hidden("dir",dir),hidden("command","make"), + hidden(g.basename+".gf",show_abstract(g))]) var files = [g.basename+".gf"] for(var i in g.concretes) { - var cname=g.basename+g.concretes[i].langcode; - files.push(cname+".gf"); + var cname=g.basename+g.concretes[i].langcode+".gf"; + files.push(cname); form.appendChild(hidden(cname, show_concrete(g.basename)(g.concretes[i]))); } editor.appendChild(form); form.submit(); form.parentNode.removeChild(form); - /* wait until upload is done */ - gfshell("i -retain "+files.join(" "),upload3) } function upload3(message) { if(message) alert(message); } -- cgit v1.2.3