GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-25 02:38:55 -06:00
Code Issues Packages Projects Releases Wiki Activity

More work on support for gfse in "gf -server" mode

Browse Source
This commit is contained in:
hallgren
2011-10-11 19:17:47 +00:00
parent ef079ff939
commit 0aba45560d
2 changed files with 56 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
src/compiler/GFServer.hs
View File

@@ -18,8 +18,10 @@ import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments,
import Network.CGI(handleErrors,liftIO) import Network.CGI(handleErrors,liftIO)
import FastCGIUtils(outputJSONP,handleCGIErrors) import FastCGIUtils(outputJSONP,handleCGIErrors)
import System.IO.Silently(hCapture) import System.IO.Silently(hCapture)
import System.Process(readProcessWithExitCode)
import System.Exit(ExitCode(..))
import Codec.Binary.UTF8.String(encodeString) import Codec.Binary.UTF8.String(encodeString)
import GF.Infra.UseIO(readBinaryFile) import GF.Infra.UseIO(readBinaryFile,writeBinaryFile)
import qualified PGFService as PS import qualified PGFService as PS
import qualified ExampleService as ES import qualified ExampleService as ES
import Paths_gf(getDataDir) import Paths_gf(getDataDir)
@@ -101,6 +103,7 @@ handle state0 cache execute1
cloud dir cmd qs = cloud dir cmd qs =
case cmd of case cmd of
"make" -> make dir qs
"upload" -> upload qs "upload" -> upload qs
"ls" -> jsonList "ls" -> jsonList
"rm" -> look "file" rm qs "rm" -> look "file" rm qs
@@ -108,8 +111,15 @@ handle state0 cache execute1
"link_directories" -> look "newdir" (link_directories dir) qs "link_directories" -> look "newdir" (link_directories dir) qs
_ -> return (state,resp400 $ "cloud command "++cmd) _ -> 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 = upload files =
do let update (name,contents)= updateFile (name++".gf") contents do let update (name,contents)= updateFile name contents
mapM_ update files mapM_ update files
return (state,resp204) return (state,resp204)
@@ -145,6 +155,40 @@ handle state0 cache execute1
do paths <- getDirectoryContents dir do paths <- getDirectoryContents dir
return [path | path<-paths, takeExtension path==ext] return [path | path<-paths, takeExtension path==ext]
-- * Dynamic content
resultpage dir cmd (ecode,stdout,stderr) files =
unlines $
"<!DOCTYPE html>":
"<title>Uploaded</title>":
"<link rel=stylesheet type=\"text/css\" HREF=\"/gfse/editor.css\" title=\"Normal\">":
"<h1>Uploaded</h1>":
"<pre>":escape cmd:"":escape stderr:escape stdout:
"</pre>":
(if ecode==ExitSuccess
then "<h3>OK</h3>":links
else "<h3 class=error_message>Error</h3>":listing)
where
links = "<dl>":
("<dt>▸ <a href=\"/minibar/minibar.html?"++dir++"\">Minibar</a>"):
"<dt>◂ <a href=\"javascript:history.back()\">Back to Editor</a>":
"</dl>":
[]
listing = concatMap listfile files
listfile (name,source) =
("<h4>"++name++"</h4><pre class=plain>"):number source:"</pre>":[]
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 '<' = "&lt;"
escape1 '&' = "&amp;"
escape1 c = [c]
-- * Static content -- * Static content
translatePath path = documentRoot options</>path -- hmm, check for ".." translatePath path = documentRoot options</>path -- hmm, check for ".."
@@ -167,8 +211,9 @@ serveStaticFile' path =
logPutStrLn = putStrLn logPutStrLn = putStrLn
-- * Standard HTTP responses -- * Standard HTTP responses
ok200 body = Response 200 [plainUTF8,noCache] (encodeString body) ok200 = Response 200 [plainUTF8,noCache] . encodeString
ok200' t body = Response 200 [t] body ok200' t = Response 200 [t]
html200 = ok200' htmlUTF8 . encodeString
resp204 = Response 204 [] "" -- no content resp204 = Response 204 [] "" -- no content
resp400 msg = Response 400 [plain] $ "Bad request: "++msg++"\n" resp400 msg = Response 400 [plain] $ "Bad request: "++msg++"\n"
resp404 path = Response 404 [plain] $ "Not found: "++path++"\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 -- * Content types
plain = ct "text/plain" plain = ct "text/plain"
plainUTF8 = ct "text/plain; charset=UTF-8" plainUTF8 = ct "text/plain; charset=UTF-8"
htmlUTF8 = ct "text/html; charset=UTF-8"
ct t = ("Content-Type",t) ct t = ("Content-Type",t)
contentTypeFromExt ext = contentTypeFromExt ext =
@@ -195,10 +241,10 @@ contentTypeFromExt ext =
-- * IO utilities -- * IO utilities
updateFile path new = updateFile path new =
do old <- try $ readFile path do old <- try $ readBinaryFile path
when (Right new/=old) $ do logPutStrLn $ "Updating "++path when (Right new/=old) $ do logPutStrLn $ "Updating "++path
seq (either (const 0) length old) $ seq (either (const 0) length old) $
writeFile path new writeBinaryFile path new
newDirectory = newDirectory =

10
src/editor/simple/cloud2.js
View File

@@ -21,20 +21,18 @@ function remove_cloud_grammar(g) {
function upload(g) { function upload(g) {
function upload2(dir) { function upload2(dir) {
var form=node("form",{method:"post",action:"/cloud"}, var form=node("form",{method:"post",action:"/cloud"},
[hidden("dir",dir),hidden("command","upload"), [hidden("dir",dir),hidden("command","make"),
hidden(g.basename,show_abstract(g))]) hidden(g.basename+".gf",show_abstract(g))])
var files = [g.basename+".gf"] var files = [g.basename+".gf"]
for(var i in g.concretes) { for(var i in g.concretes) {
var cname=g.basename+g.concretes[i].langcode; var cname=g.basename+g.concretes[i].langcode+".gf";
files.push(cname+".gf"); files.push(cname);
form.appendChild(hidden(cname, form.appendChild(hidden(cname,
show_concrete(g.basename)(g.concretes[i]))); show_concrete(g.basename)(g.concretes[i])));
} }
editor.appendChild(form); editor.appendChild(form);
form.submit(); form.submit();
form.parentNode.removeChild(form); form.parentNode.removeChild(form);
/* wait until upload is done */
gfshell("i -retain "+files.join(" "),upload3)
} }
function upload3(message) { if(message) alert(message); } function upload3(message) { if(message) alert(message); }