GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-01 15:22:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

restore the FastCGI service and move some files back to src/server

Browse Source
This commit is contained in:
Krasimir Angelov
2022-06-22 11:18:56 +02:00
parent a8ad145aeb
commit 174cc57eb7
21 changed files with 145 additions and 711 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
Makefile
View File

@@ -16,15 +16,10 @@ else
ifeq ($(CABAL_NEW),1) ifeq ($(CABAL_NEW),1)
CMD_PFX=v1- CMD_PFX=v1-
endif endif
CMD_OPT="--force-reinstalls"
endif endif
all: src/runtime/c/libpgf.la src/runtime/haskell/dist/setup-config src/compiler/dist/setup-config all: src/runtime/c/libpgf.la src/runtime/haskell/dist/setup-config src/server/dist/setup-config src/compiler/dist/setup-config
ifeq ($(STACK),1)
stack install
else
(cd src/runtime/haskell; ${CMD} ${CMD_PFX}install)
(cd src/compiler; ${CMD} ${CMD_PFX}install)
endif
src/runtime/c/libpgf.la: src/runtime/c/Makefile src/runtime/c/libpgf.la: src/runtime/c/Makefile
(cd src/runtime/c; make; sudo make install) (cd src/runtime/c; make; sudo make install)
@@ -36,14 +31,13 @@ src/runtime/c/Makefile.in src/runtime/c/configure: src/runtime/c/configure.ac sr
(cd src/runtime/c; autoreconf -i) (cd src/runtime/c; autoreconf -i)
src/runtime/haskell/dist/setup-config: src/runtime/c/libpgf.la src/runtime/haskell/pgf2.cabal src/runtime/haskell/dist/setup-config: src/runtime/c/libpgf.la src/runtime/haskell/pgf2.cabal
ifneq ($(STACK),1) (cd src/runtime/haskell; ${CMD} ${CMD_PFX}install ${CMD_OPT})
(cd src/runtime/haskell; cabal ${CMD_PFX}configure)
endif
src/compiler/dist/setup-config: src/compiler/gf.cabal src/compiler/Setup.hs src/compiler/WebSetup.hs src/server/dist/setup-config: src/server/pgf-service.cabal src/runtime/haskell/dist/setup-config
ifneq ($(STACK),1) (cd src/server; ${CMD} ${CMD_PFX}install ${CMD_OPT})
(cd src/compiler; cabal ${CMD_PFX}configure)
endif src/compiler/dist/setup-config: src/compiler/gf.cabal src/compiler/Setup.hs src/compiler/WebSetup.hs src/runtime/haskell/dist/setup-config src/server/dist/setup-config
(cd src/compiler; ${CMD} ${CMD_PFX}install ${CMD_OPT})
doc: doc:
${CMD} ${CMD_PFX}haddock ${CMD} ${CMD_PFX}haddock

6
src/compiler/GF/Server.hs
View File

@@ -32,7 +32,7 @@ import Network.URI(URI(..))
import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache) import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
import Network.CGI(handleErrors,liftIO) import Network.CGI(handleErrors,liftIO)
import GF.Server.CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile import CGIUtils(handleCGIErrors)
import Text.JSON(encode,showJSON,makeObj) import Text.JSON(encode,showJSON,makeObj)
--import System.IO.Silently(hCapture) --import System.IO.Silently(hCapture)
import System.Process(readProcessWithExitCode) import System.Process(readProcessWithExitCode)
@@ -41,13 +41,13 @@ import Codec.Binary.UTF8.String(decodeString,encodeString)
import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn) import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
import GF.Infra.SIO(captureSIO) import GF.Infra.SIO(captureSIO)
import GF.Data.Utilities(apSnd,mapSnd) import GF.Data.Utilities(apSnd,mapSnd)
import qualified GF.Server.PGFService as PS import qualified PGFService as PS
import Data.Version(showVersion) import Data.Version(showVersion)
import Paths_gf(getDataDir,version) import Paths_gf(getDataDir,version)
import GF.Infra.BuildInfo (buildInfo) import GF.Infra.BuildInfo (buildInfo)
import GF.Server.SimpleEditor.Convert(parseModule) import GF.Server.SimpleEditor.Convert(parseModule)
import GF.Server.RunHTTP(cgiHandler) import GF.Server.RunHTTP(cgiHandler)
import GF.Server.URLEncoding(decodeQuery) import URLEncoding(decodeQuery)
--logFile :: FilePath --logFile :: FilePath
--logFile = "pgf-error.log" --logFile = "pgf-error.log"

11
src/compiler/GF/Server/CGI.hs
View File

@@ -1,11 +0,0 @@
-- | Isolate dependencies on the problematic cgi package to this module
module GF.Server.CGI(module C) where
import Network.CGI as C(
CGI,ContentType(..),Accept(..),Language(..),
getVarWithDefault,readInput,negotiate,requestAcceptLanguage,getInput,
setHeader,output,outputFPS,outputError,
handleErrors,
liftIO)
import Network.CGI.Protocol as C(CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..))
import Network.CGI.Monad as C(runCGIT)

10
src/compiler/GF/Server/RunHTTP.hs
View File

@@ -1,10 +1,10 @@
module GF.Server.RunHTTP(runHTTP,Options(..),cgiHandler) where module GF.Server.RunHTTP(runHTTP,Options(..),cgiHandler) where
import GF.Server.CGI(ContentType(..), import Network.CGI(ContentType(..))
CGIResult(..),CGIRequest(..),Input(..), import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..), Headers,HeaderName(..))
runCGIT) import Network.CGI.Monad(runCGIT)
import GF.Server.URLEncoding(decodeQuery) import URLEncoding(decodeQuery)
import Network.URI(uriPath,uriQuery) import Network.URI(uriPath,uriQuery)
import Network.Shed.Httpd(initServer,Request(..),Response(..)) import Network.Shed.Httpd(initServer,Request(..),Response(..))
import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack,empty) import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack,empty)

26
src/compiler/GF/Server/ServeStaticFile.hs
View File

@@ -1,26 +0,0 @@
module ServeStaticFile where
import System.FilePath
import System.Directory(doesDirectoryExist)
import CGI(setHeader,outputFPS,liftIO)
import qualified Data.ByteString.Lazy.Char8 as BS
serveStaticFile path =
do b <- liftIO $ doesDirectoryExist path
let path' = if b then path </> "index.html" else path
serveStaticFile' path'
serveStaticFile' path =
do setHeader "Content-Type" (contentTypeFromExt (takeExtension path))
outputFPS =<< liftIO (BS.readFile path)
contentTypeFromExt ext =
case ext of
".html" -> "text/html"
".htm" -> "text/html"
".xml" -> "text/xml"
".txt" -> "text/plain"
".css" -> "text/css"
".js" -> "text/javascript"
".png" -> "image/png"
".jpg" -> "image/jpg"
_ -> "application/octet-stream"

91
src/compiler/GF/Server/Setup.hs
View File

@@ -1,91 +0,0 @@
{-# OPTIONS_GHC -fwarn-unused-imports #-}
import Control.Monad(when)
import System.Directory(createDirectoryIfMissing,doesFileExist,
getDirectoryContents,copyFile,removeFile)
import System.FilePath((</>))
import System.Process(system)
import System.Exit(ExitCode(..))
import Distribution.Simple
import Distribution.Simple.Setup
import Distribution.Simple.LocalBuildInfo(datadir,buildDir,absoluteInstallDirs)
main :: IO ()
main = defaultMainWithHooks simpleUserHooks{ postInst = instWWW
, postCopy = copyWWW
}
--------------------------------------------------------------------------------
-- To test the GF web service and minibar, use "cabal install" (or
-- "runhaskell Setup.hs install") to install the program pgf-http, the
-- example grammars listed below, and the minibar. Then start the server with
-- the command "pgf-http" and open http://localhost:41296/minibar/minibar.html
-- in your web browser (Firefox, Safari, Opera or Chrome).
example_grammars =
-- (pgf, tmp, src)
[("Foods.pgf","foods",
".."</>".."</>"contrib"</>"summerschool"</>"foods"</>"Foods???.gf"),
("Letter.pgf","letter",
".."</>".."</>"examples"</>"letter"</>"Letter???.gf")]
minibar_src = ".."</>"www"</>"minibar"
--------------------------------------------------------------------------------
instWWW args flags pki lbi = setupWWW args dest pki lbi
where
dest = NoCopyDest
copyWWW args flags pki lbi = setupWWW args dest pki lbi
where
dest = case copyDest flags of
NoFlag -> NoCopyDest
Flag d -> d
setupWWW args dest pkg lbi =
do mapM_ (createDirectoryIfMissing True) [grammars_dir,minibar_dir]
mapM_ build_pgf example_grammars
copy_minibar
create_root_index
where
grammars_dir = www_dir </> "grammars"
minibar_dir = www_dir </> "minibar"
www_dir = datadir (absoluteInstallDirs pkg lbi dest) </> "www"
gfo_dir = buildDir lbi </> "gfo"
build_pgf (pgf,tmp,src) =
do createDirectoryIfMissing True tmp_dir
execute cmd
copyFile pgf (grammars_dir</>pgf)
removeFile pgf
where
tmp_dir = gfo_dir</>tmp
cmd = "gf -make -s -optimize-pgf --gfo-dir="++tmp_dir++
-- " --output-dir="++grammars_dir++ -- has no effect?!
" "++src
copy_minibar =
do files <- getDirectoryContents minibar_src
mapM_ copy files
where
copy file =
do isFile <- doesFileExist src
when isFile $ copyFile src (minibar_dir</>file)
where
src = minibar_src</>file
create_root_index = writeFile (www_dir</>"index.html") index_html
index_html = "<h1>PGF service</h1>\n<h2>Available demos</h2>\n"
++"<ul><li><a href=\"minibar/minibar.html\">Minibar</a></ul>"
++"Additional grammars can be installed in"
++"<blockquote><code>"++grammars_dir++"</code></blockquote>"
++"<a href=\"http://www.grammaticalframework.org/\">"
++"Grammatical Framework</a>"
execute command =
do putStrLn command
e <- system command
case e of
ExitSuccess -> return ()
_ -> fail "Command failed"
return ()

49
src/compiler/GF/Server/exec/pgf-http.hs
View File

@@ -1,49 +0,0 @@
import Network.CGI(requestMethod,getVarWithDefault,logCGI,handleErrors,liftIO)
import System.Environment(getArgs)
import System.Directory(getDirectoryContents)
import System.FilePath(takeExtension,takeFileName,takeDirectory,(</>))
import RunHTTP(runHTTP,Options(..))
import ServeStaticFile(serveStaticFile)
import PGFService(cgiMain',getPath,stderrToFile,logFile,newPGFCache)
import CGIUtils(outputJSONP,handleCGIErrors)
import Paths_gf_server(getDataDir)
main :: IO ()
main = do datadir <- getDataDir
let defaults = Options { documentRoot = datadir</>"www",
port = 41296 }
cache <- newPGFCache
args <- getArgs
options <- case args of
[] -> return defaults
[port] -> do p <- readIO port
return defaults{port=p}
putStrLn $ "Starting HTTP server, open http://localhost:"
++show (port options)++"/ in your web browser.\n"
print options
putStrLn $ "logFile="++logFile
stderrToFile logFile
httpMain cache options
httpMain cache options = runHTTP options (do log ; serve =<< getPath)
where
log = do method <- requestMethod
uri <- getVarWithDefault "REQUEST_URI" "-"
logCGI $ method++" "++uri
serve path =
handleErrors . handleCGIErrors $
if takeExtension path==".pgf"
then cgiMain' cache path
else if takeFileName path=="grammars.cgi"
then grammarList (takeDirectory path)
else serveStaticFile path
grammarList dir =
do paths <- liftIO $ getDirectoryContents dir
let pgfs = [path|path<-paths, takeExtension path==".pgf"]
outputJSONP pgfs

122
src/compiler/GF/Server/gf-server-jsapi.js
View File

@@ -1,122 +0,0 @@
var gf = new Object();
var pgf_base_url = "pgf";
gf.grammars = function (callback) {
gf.httpGetJSONP(pgf_base_url, callback);
};
gf.grammar = function (grammar, callback) {
gf.callFunction(grammar, "", [], callback);
};
gf.parse = function (grammar,input,from,cat,callback) {
var args = [];
args["input"] = input;
args["from"] = from;
args["cat"] = cat;
gf.callFunction(grammar, "parse", args, callback);
};
gf.complete = function (grammar,input,from,cat,callback) {
var args = [];
args["input"] = input;
args["from"] = from;
args["cat"] = cat;
gf.callFunction(grammar, "complete", args, callback);
};
gf.linearize = function (grammar,tree,to,callback) {
var args = [];
args["tree"] = tree;
args["to"] = to;
gf.callFunction(grammar, "linearize", args, callback);
};
gf.random = function (grammar,cat,limit,callback) {
var args = [];
args["cat"] = cat;
args["limit"] = limit;
gf.callFunction(grammar, "random", args, callback);
};
gf.translate = function (grammar,input,from,to,cat,callback) {
var args = [];
args["input"] = input;
args["from"] = from;
args["to"] = to;
args["cat"] = cat;
gf.callFunction(grammar, "translate", args, callback);
};
gf.callFunction = function (grammar, fun, args, callback) {
var query = "";
for (var i in args) {
query += (query == "") ? "?" : "&";
query += i + "=" + encodeURIComponent(args[i]);
}
var url = pgf_base_url + "/" + grammar +"/" + fun + query;
// FIXME: if same domain, use gf.httpGetText
gf.httpGetJSONP(url, callback);
}
gf.httpGetJSONP = function (url, callback) {
var script = document.createElement("script");
if (!window.jsonCallbacks) {
window.jsonCallbacks = new Array();
}
var callbackIndex = window.jsonCallbacks.length;
window.jsonCallbacks.push(function (output) {
// get rid of the script tag
document.getElementsByTagName("head")[0].removeChild(script);
// let this function be garbage-collected
window.jsonCallbacks[callbackIndex] = null;
// shrink the array if possible
while (window.jsonCallbacks.length > 0 && window.jsonCallbacks[window.jsonCallbacks.length-1] == null) {
window.jsonCallbacks.pop();
}
callback(output);
});
var callbackName = "jsonCallbacks[" + callbackIndex + "]";
var questionMarkPos = url.indexOf("?");
if (questionMarkPos > -1) {
url += (questionMarkPos < url.length-1) ? "&" : "";
} else {
url += "?";
}
url += "jsonp=" + callbackName;
script.setAttribute("src", url);
script.setAttribute("type", "text/javascript");
document.getElementsByTagName("head")[0].appendChild(script);
};
gf.httpGetText = function (url, callback) {
var XMLHttpRequestObject = false;
if (window.XMLHttpRequest) {
XMLHttpRequestObject = new XMLHttpRequest();
} else if (window.ActiveXObject) {
XMLHttpRequestObject = new ActiveXObject("Microsoft.XMLHTTP");
}
if (XMLHttpRequestObject) {
XMLHttpRequestObject.open("GET", url);
XMLHttpRequestObject.onreadystatechange = function () {
if (XMLHttpRequestObject.readyState == 4 && XMLHttpRequestObject.status == 200) {
callback(XMLHttpRequestObject.responseText);
delete XMLHttpRequestObject;
XMLHttpRequestObject = null;
}
}
XMLHttpRequestObject.send(null);
}
};
gf.readJSON = function (text) {
return eval("("+text+")");
};

111
src/compiler/GF/Server/simple-client.html
View File

@@ -1,111 +0,0 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
<meta name="viewport" content="initial-scale=2.3" />
<meta name="viewport" content="width=320; initial-scale=1.0; maximum-scale=1.0;" />
<link rel="stylesheet" type="text/css" href="translator.css" />
<script type="text/javascript" src="gf-server-jsapi.js"></script>
<script type="text/javascript" src="translator.js"></script>
<script type="text/javascript">
function getGrammar () {
return document.getElementById('grammar').value;
}
function updateTranslation () {
var input = document.getElementById('inputText').value;
var fromLang = document.getElementById('fromLang').value;
var toLang = document.getElementById('toLang').value;
var output = document.getElementById('translation');
var callback = function(translation) {
clearTranslation();
output.appendChild(formatTranslation(translation));
};
gf.translate(getGrammar(), input, fromLang, toLang, '', callback);
}
function updateGrammars () {
gf.grammars(populateGrammars);
}
function populateGrammars (grammars) {
var l = document.getElementById('grammar');
var langs = grammar.languages;
for (var i in grammars) {
addOption(l, grammars[i].name, grammars[i].name);
}
updateLanguages();
}
function updateLanguages () {
gf.grammar(getGrammar(), populateLangs);
}
function populateLangs (grammar) {
var f = document.getElementById('fromLang');
var t = document.getElementById('toLang');
var langs = grammar.languages;
for (var i in langs) {
if (langs[i].canParse) {
addOption(f, langs[i].name, langs[i].name);
}
addOption(t, langs[i].name, langs[i].name);
}
}
function updateCompletion() {
var input = document.getElementById('inputText').value;
var fromLang = document.getElementById('fromLang').value;
var completions = document.getElementById('completion');
// if (document.getElementById('enableCompletion').checked) {
var callback = function(output) {
clearCompletion();
completions.appendChild(formatCompletions(output));
};
gf.complete(getGrammar(), input, fromLang, '', callback);
// }
}
function update() {
// updateCompletion();
updateTranslation();
}
function clearTranslation() {
var output = document.getElementById('translation');
removeChildren(output);
}
function clearCompletion() {
var completions = document.getElementById('completion');
removeChildren(completions);
}
function initialize() {
updateGrammars();
}
</script>
<title>AJAX GF Translator</title>
</head>
<body onload="initialize()">
<div id="translator">
<form onsubmit="update(); return false;">
<p>
<input type="text" id="inputText" value="" size="50" />
</p>
<p>
<label>Grammar: <select id="grammar" onchange="updateLanguages()"></select></label>
<label>From: <select id="fromLang" onchange="update()"><option value="" selected="selected">Any language</option></select></label>
<label>To: <select id="toLang" onchange="update()"><option value="" selected="selected">All languages</option></select></label>
<input type="button" value="Completions" onclick="updateCompletion()" />
<input type="submit" value="Translate" />
</p>
</form>
<div id="completion"></div>
<div id="translation"></div>
</div>
</body>
</html>

32
src/compiler/GF/Server/transfer/Fold.hs
View File

@@ -1,32 +0,0 @@
module Fold where
import PGF2
import Data.Map as M (lookup, fromList)
--import Debug.Trace
foldable = fromList [(c, "bin_" ++ c) | c <- ops]
where ops = words "plus times and or xor cartesian_product intersect union"
fold :: Expr -> Expr
fold t =
case unApp t of
Just (i,[x]) ->
case M.lookup i foldable of
Just j -> appFold j x
_ -> mkApp i [fold x]
Just (i,xs) -> mkApp i $ map fold xs
_ -> t
<<<<<<< HEAD
appFold :: Fun -> Expr -> Expr
appFold j t =
=======
appFold :: CId -> Tree -> Tree
appFold j t =
>>>>>>> master
case unApp t of
Just (i,[t,ts]) | isPre i "Cons" -> mkApp j [fold t, appFold j ts]
Just (i,[t,s]) | isPre i "Base" -> mkApp j [fold t, fold s]
where isPre i s = take 4 (show i) == s

76
src/compiler/GF/Server/translator.css
View File

@@ -1,76 +0,0 @@
body {
color: black;
background-color: white;
font-family: sans-serif;
}
dl {
margin: 0;
padding: 0;
}
dt {
margin: 0;
padding: 0;
}
dl dd {
margin: 0;
padding: 0;
}
ul {
margin: 0;
padding: 0;
}
li {
list-style-type: none;
margin: 0;
padding: 0;
}
/* Translator widget */
#translator {
}
/* Translations */
#translation {
clear: both;
}
#translation dl {
border-width: 0 0 1px 0;
border-style: solid;
border-color: #c0c0c0;
}
#translation dt {
display: none;
}
#translation dd {
border-width: 1px 0 0 0;
border-style: solid;
border-color: #c0c0c0;
}
/* Completions */
#completion {
font-size: 80%;
color: #c0c0c0;
white-space: nowrap;
width: 100%;
overflow: hidden;
}
#completion li {
display: inline;
padding: 0 0.1em;
}

51
src/compiler/GF/Server/translator.js
View File

@@ -1,51 +0,0 @@
function formatTranslation (outputs) {
var dl1 = document.createElement("dl");
for (var i in outputs) {
var o = outputs[i];
addDefinition(dl1, document.createTextNode(o.to), document.createTextNode(o.text));
}
return dl1;
}
function formatCompletions (compls) {
var ul = document.createElement("ul");
for (var i in compls) {
var c = compls[i];
addItem(ul, document.createTextNode(c.text));
}
return ul;
}
/* DOM utilities for specific tags */
function addDefinition (dl, t, d) {
var dt = document.createElement("dt");
dt.appendChild(t);
dl.appendChild(dt);
var dd = document.createElement("dd");
dd.appendChild(d);
dl.appendChild(dd);
}
function addItem (ul, i) {
var li = document.createElement("li");
li.appendChild(i);
ul.appendChild(li);
}
function addOption (select, value, content) {
var option = document.createElement("option");
option.value = value;
option.appendChild(document.createTextNode(content));
select.appendChild(option);
}
/* General DOM utilities */
/* Removes all the children of a node */
function removeChildren(node) {
while (node.hasChildNodes()) {
node.removeChild(node.firstChild);
}
}

6
src/compiler/gf.cabal
View File

@@ -164,7 +164,6 @@ executable gf
GF.Infra.Ident GF.Infra.Ident
GF.Infra.Location GF.Infra.Location
GF.Infra.SIO GF.Infra.SIO
GF.Infra.Cache
GF.JavaScript.AbsJS GF.JavaScript.AbsJS
GF.JavaScript.PrintJS GF.JavaScript.PrintJS
GF.Quiz GF.Quiz
@@ -212,6 +211,7 @@ executable gf
if flag(server) if flag(server)
build-depends: build-depends:
pgf-service,
cgi >= 3001.3.0.2 && < 3001.6, cgi >= 3001.3.0.2 && < 3001.6,
httpd-shed >= 0.4.0 && < 0.5, httpd-shed >= 0.4.0 && < 0.5,
network>=2.3 && <3.2 network>=2.3 && <3.2
@@ -226,14 +226,10 @@ executable gf
cpp-options: -DSERVER_MODE cpp-options: -DSERVER_MODE
other-modules: other-modules:
GF.Server GF.Server
GF.Server.PGFService
GF.Server.RunHTTP GF.Server.RunHTTP
GF.Server.SimpleEditor.Convert GF.Server.SimpleEditor.Convert
GF.Server.SimpleEditor.JSON GF.Server.SimpleEditor.JSON
GF.Server.SimpleEditor.Syntax GF.Server.SimpleEditor.Syntax
GF.Server.URLEncoding
GF.Server.CGI
GF.Server.CGIUtils
if flag(interrupt) if flag(interrupt)
cpp-options: -DUSE_INTERRUPT cpp-options: -DUSE_INTERRUPT

15
src/compiler/GF/Server/CGIUtils.hs → src/server/CGIUtils.hs
View File

@@ -1,10 +1,10 @@
{-# LANGUAGE DeriveDataTypeable, CPP #-} {-# LANGUAGE DeriveDataTypeable, CPP #-}
-- | CGI utility functions for output, error handling and logging -- | CGI utility functions for output, error handling and logging
module GF.Server.CGIUtils (throwCGIError, handleCGIErrors, module CGIUtils (throwCGIError, handleCGIErrors,
stderrToFile,logError, stderrToFile,logError,
outputJSONP,outputEncodedJSONP, outputJSONP,outputEncodedJSONP,
outputPNG,outputBinary,outputBinary', outputPNG,outputBinary,outputBinary',
outputHTML,outputPlain,outputText) where outputHTML,outputPlain,outputText) where
import Control.Exception(Exception(..),SomeException(..),throw) import Control.Exception(Exception(..),SomeException(..),throw)
import Data.Typeable(Typeable,cast) import Data.Typeable(Typeable,cast)
@@ -14,14 +14,13 @@ import System.IO(hPutStrLn,stderr)
import System.Posix import System.Posix
#endif #endif
import GF.Server.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError, import Network.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
getInput) getInput)
import Text.JSON import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString) import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Control.Monad.Catch (MonadThrow(throwM)) import Control.Monad.Catch (MonadThrow(throwM))
import Network.CGI.Monad (catchCGI)
import Control.Monad.Catch (MonadCatch(catch)) import Control.Monad.Catch (MonadCatch(catch))
-- * Logging -- * Logging

2
src/compiler/GF/Infra/Cache.hs → src/server/Cache.hs
View File

@@ -1,5 +1,5 @@
-- | A file cache to avoid reading and parsing the same file many times -- | A file cache to avoid reading and parsing the same file many times
module GF.Infra.Cache (Cache,newCache,flushCache,expireCache,listCache,readCache,readCache') where module Cache (Cache,newCache,flushCache,expireCache,listCache,readCache,readCache') where
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Data.Map (Map) import Data.Map (Map)

0
src/compiler/GF/Server/LICENSE → src/server/LICENSE
View File

138
src/compiler/GF/Server/PGFService.hs → src/server/PGFService.hs
View File

@@ -1,49 +1,37 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module GF.Server.PGFService(cgiMain,cgiMain',getPath, module PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile, logFile,stderrToFile,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
import PGF2 import PGF2
import PGF2.Transactions import PGF2.Transactions
import GF.Text.Lexing import Cache
import GF.Infra.Cache import Network.CGI(CGI,readInput,getInput,getVarWithDefault,
import GF.Server.CGIUtils(outputJSONP,outputPlain,outputHTML,outputText, CGIResult,handleErrors,setHeader,
outputBinary,outputBinary', Accept(..),Language(..),negotiate,liftIO)
logError,handleCGIErrors,throwCGIError,stderrToFile) import CGIUtils(outputJSONP,outputPlain,
import GF.Server.CGI(CGI,readInput,getInput,getVarWithDefault, outputBinary,outputBinary',
CGIResult,requestAcceptLanguage,handleErrors,setHeader, handleCGIErrors,throwCGIError,stderrToFile)
Accept(..),Language(..),negotiate,liftIO) import URLEncoding
import GF.Server.URLEncoding
import Data.Time.Clock(UTCTime)
import Data.Time.Format(formatTime) import Data.Time.Format(formatTime)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format(defaultTimeLocale,rfc822DateFormat) import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
#else
import System.Locale(defaultTimeLocale,rfc822DateFormat)
#endif
import Text.JSON import Text.JSON
import Text.PrettyPrint as PP(render, text, (<+>))
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString) import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Control.Concurrent import Control.Concurrent
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Monad import Control.Monad
import Control.Monad.State(State,evalState,get,put)
import Control.Monad.Catch(bracket_) import Control.Monad.Catch(bracket_)
import Data.Char import Data.Char
--import Data.Function (on)
import Data.List ({-sortBy,-}intersperse,mapAccumL,nub,isSuffixOf,nubBy,stripPrefix)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import System.Random
import System.Process import System.Process
import System.Exit import System.Exit
import System.IO import System.IO
import System.IO.Error(isDoesNotExistError) import System.IO.Error(isDoesNotExistError)
import System.Directory(removeFile) import System.FilePath(takeExtension)
import System.FilePath(takeExtension,dropExtension,takeDirectory,(</>),(<.>))
import System.Mem(performGC) import System.Mem(performGC)
catchIOE :: IO a -> (E.IOException -> IO a) -> IO a catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
@@ -121,12 +109,12 @@ pgfMain qsem command (t,pgf) =
"linearizeAll" -> out t=<< linAll # tree % to "linearizeAll" -> out t=<< linAll # tree % to
"translate" -> withQSem qsem $ "translate" -> withQSem qsem $
out t=<<join(trans # input % cat % to % start % limit%treeopts) out t=<<join(trans # input % cat % to % start % limit%treeopts)
"lookupmorpho" -> out t=<< morpho # from1 % textInput "lookupmorpho" -> out t=<< morpho # from % textInput
"lookupcohorts" -> out t=<< cohorts # from1 % getInput "filter" % textInput "lookupcohorts" -> out t=<< cohorts # from % getInput "filter" % textInput
"flush" -> out t=<< flush "flush" -> out t=<< flush
"grammar" -> out t grammar "grammar" -> out t grammar
"abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree "abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
"parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from1 %tree "parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from %tree
"wordforword" -> out t =<< wordforword # input % cat % to "wordforword" -> out t =<< wordforword # input % cat % to
_ -> badRequest "Unknown command" command _ -> badRequest "Unknown command" command
where where
@@ -203,16 +191,16 @@ pgfMain qsem command (t,pgf) =
mkChartPArg (PArg _ fid) = showJSON fid mkChartPArg (PArg _ fid) = showJSON fid
-} -}
linAll tree to = showJSON (linAll' tree to) linAll tree to = showJSON (linAll' tree to)
linAll' tree (tos,unlex) = linAll' tree tos =
[makeObj ["to".=to, [makeObj ["to".=to,
"texts".=map unlex (linearizeAll c tree)]|(to,c)<-tos] "texts".=linearizeAll c tree]|(to,c)<-tos]
lin tree to = showJSON (lin' tree to) lin tree to = showJSON (lin' tree to)
lin' tree (tos,unlex) = lin' tree tos =
[makeObj ["to".=to,"text".=unlex (linearize c tree)]|(to,c)<-tos] [makeObj ["to".=to,"text".=linearize c tree]|(to,c)<-tos]
bracketedLin tree to = showJSON (bracketedLin' tree to) bracketedLin tree to = showJSON (bracketedLin' tree to)
bracketedLin' tree (tos,unlex) = bracketedLin' tree tos =
[makeObj ["to".=to,"brackets".=showJSON (bracketedLinearize c tree)]|(to,c)<-tos] [makeObj ["to".=to,"brackets".=showJSON (bracketedLinearize c tree)]|(to,c)<-tos]
trans input@((from,_),_) cat to start mlimit (trie,jsontree) = trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
@@ -251,17 +239,17 @@ pgfMain qsem command (t,pgf) =
(lookupCohorts concr input)] (lookupCohorts concr input)]
wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
where
jsonWFW from rs =
showJSON
[makeObj
["from".=from,
"translations".=[makeObj ["linearizations".=
[makeObj["to".=to,"text".=text]
| (to,text)<-rs]]]]]
jsonWFW from rs = wordforword' inp@((from,concr),input) cat tos =
showJSON [(to,unwords $ map (lin_word' c) pws)
[makeObj
["from".=from,
"translations".=[makeObj ["linearizations".=
[makeObj["to".=to,"text".=text]
| (to,text)<-rs]]]]]
wordforword' inp@((from,concr),input) cat (tos,unlex) =
[(to,unlex . unwords $ map (lin_word' c) pws)
|let pws=map parse_word' (words input),(to,c)<-tos] |let pws=map parse_word' (words input),(to,c)<-tos]
where where
lin_word' c = either id (lin1 c) lin_word' c = either id (lin1 c)
@@ -294,21 +282,19 @@ pgfMain qsem command (t,pgf) =
--- ---
input = lexit # from % textInput input = (,) # from % textInput
where
lexit (from,lex) input = (from,lex input)
from = maybe (missing "from") getlexer =<< from' from = maybe (missing "from") return =<< getLang "from"
where
getlexer f@(_,concr) = (,) f # c_lexer concr
from1 = maybe (missing "from") return =<< from' to = getLangs "to"
from' = getLang "from"
to = (,) # getLangs "to" % unlexerC (const False) getLangs i = mapM readLang . maybe [] words =<< getInput i
getLangs = getLangs' readLang getLang i = do
getLang = getLang' readLang mlang <- getInput i
case mlang of
Just lang@(_:_) -> Just # readLang lang
_ -> return Nothing
readLang :: String -> CGI (String,Concr) readLang :: String -> CGI (String,Concr)
readLang lang = readLang lang =
@@ -319,42 +305,6 @@ pgfMain qsem command (t,pgf) =
tree = do s <- maybe (missing "tree") return =<< getInput1 "tree" tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
maybe (badRequest "bad tree" s) return (readExpr s) maybe (badRequest "bad tree" s) return (readExpr s)
c_lexer concr = lexer (not . null . lookupMorpho concr)
--------------------------------------------------------------------------------
-- * Lexing
-- | Standard lexers
lexer good = maybe (return id) lexerfun =<< getInput "lexer"
where
lexerfun name =
case stringOp good ("lex"++name) of
Just fn -> return fn
Nothing -> badRequest "Unknown lexer" name
type Unlexer = String->String
-- | Unlexing for the C runtime system, &+ is already applied
unlexerC :: (String -> Bool) -> CGI Unlexer
unlexerC = unlexer' id
-- | Unlexing for the Haskell runtime system, the default is to just apply &+
unlexerH :: CGI Unlexer
unlexerH = unlexer' (unwords . bindTok . words) (const False)
unlexer' defaultUnlexer good =
maybe (return defaultUnlexer) unlexerfun =<< getInput "unlexer"
where
unlexerfun name =
case stringOp good ("unlex"++name) of
Just fn -> return (fn . cleanMarker)
Nothing -> badRequest "Unknown unlexer" name
cleanMarker ('+':cs) = cs
cleanMarker ('*':cs) = cs
cleanMarker cs = cs
out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
setHeader "Last-Modified" fmt setHeader "Last-Modified" fmt
@@ -367,15 +317,6 @@ nonEmpty r = r
textInput :: CGI String textInput :: CGI String
textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i
getLang' readLang i =
do mlang <- getInput i
case mlang of
Just l@(_:_) -> Just # readLang l
_ -> return Nothing
limit, depth :: CGI (Maybe Int) limit, depth :: CGI (Maybe Int)
limit = readInput "limit" limit = readInput "limit"
depth = readInput "depth" depth = readInput "depth"
@@ -401,7 +342,6 @@ throw code msg extra =
format def = maybe def id # getInput "format" format def = maybe def id # getInput "format"
type From = (Maybe Concr,String) type From = (Maybe Concr,String)
type To = ([Concr],Unlexer)
type TreeOpts = (Bool,Bool) -- (trie,jsontree) type TreeOpts = (Bool,Bool) -- (trie,jsontree)
outputGraphviz code = outputGraphviz code =

2
src/compiler/GF/Server/URLEncoding.hs → src/server/URLEncoding.hs
View File

@@ -1,4 +1,4 @@
module GF.Server.URLEncoding(urlDecodeUnicode,decodeQuery) where module URLEncoding(urlDecodeUnicode,decodeQuery) where
import Data.Bits (shiftL, (.|.)) import Data.Bits (shiftL, (.|.))
import Data.Char (chr,digitToInt,isHexDigit) import Data.Char (chr,digitToInt,isHexDigit)

10
src/compiler/GF/Server/lighttpd.conf → src/server/lighttpd.conf
View File

@@ -55,14 +55,14 @@ fastcgi.debug = 0
fastcgi.server = (".pgf" => fastcgi.server = (".pgf" =>
(( ((
"socket" => basedir + "/" + var.PID + "-pgf.socket", "socket" => basedir + "/" + var.PID + "-pgf.socket",
"bin-path" => basedir + "/dist/build/pgf-service/pgf-service", "bin-path" => basedir + "/dist/build/pgf-service/pgf-fcgi",
# Use 2 OS threads (to be able to use 2 cores). # Use 2 OS threads (to be able to use 2 cores).
# Limit heap size to 512 MB. # Limit heap size to 512 MB.
"bin-environment" => ("GHCRTS" => "-N2 -M512M"), "bin-environment" => ("GHCRTS" => "-N2 -M512M"),
"min-procs" => 1, "min-procs" => 1,
"max-procs" => 1, "max-procs" => 1,
"broken-scriptfilename" => "disable", "broken-scriptfilename" => "disable",
"check-local" => "disable" "check-local" => "disable"
)), )),
".fcgi" => ".fcgi" =>
(( ((
@@ -72,7 +72,7 @@ fastcgi.server = (".pgf" =>
"min-procs" => 1, "min-procs" => 1,
"max-procs" => 1, "max-procs" => 1,
"broken-scriptfilename" => "disable", "broken-scriptfilename" => "disable",
"check-local" => "disable" "check-local" => "disable"
)) ))
) )

2
src/compiler/GF/Server/exec/pgf-fcgi.hs → src/server/pgf-fcgi.hs
View File

@@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
import Control.Concurrent(forkIO) import Control.Concurrent(forkIO)
import Network.FastCGI(runFastCGI,runFastCGIConcurrent') import Network.FastCGI
import PGFService(cgiMain,newPGFCache,stderrToFile,logFile) import PGFService(cgiMain,newPGFCache,stderrToFile,logFile)

74
src/server/pgf-service.cabal Normal file
View File

@@ -0,0 +1,74 @@
name: pgf-service
version: 1.0
cabal-version: >= 1.8
build-type: Simple
license: GPL
license-file: LICENSE
synopsis: CGI library and FastCGI Service for Grammatical Framework
flag fastcgi
Description: Build library & pgf-fcgi executable with fastcgi support
Default: True
flag network-uri
description: Get Network.URI from the network-uri package
default: True
Library
exposed-modules: PGFService URLEncoding CGIUtils Cache
build-depends: base >=4.2 && <5,
time,
directory,
filepath,
containers,
process,
pgf2 >= 2,
cgi >= 3001.1.7.3,
httpd-shed>=0.4.0.2,
mtl,
exceptions,
json >= 0.3.3,
utf8-string >= 0.3.1.1,
bytestring,
pretty,
random
if flag(network-uri)
build-depends: network-uri>=2.6, network>=2.6
else
build-depends: network>=2.3 && <2.6
ghc-options: -fwarn-unused-imports
if os(windows)
ghc-options: -optl-mwindows
else
build-depends: unix
executable pgf-fcgi
main-is: pgf-fcgi.hs
other-modules: URLEncoding Cache CGIUtils PGFService
ghc-options: -threaded -fwarn-unused-imports
if impl(ghc>=7.0)
ghc-options: -rtsopts
if flag(fastcgi)
build-depends: fastcgi >= 3001.0.2.2
-- Install it in Ubuntu with: apt-get install libghc-fastcgi-dev
else
Buildable: False
build-depends: base >=4.2 && <5, pgf-service,
time,
directory,
filepath,
containers,
process,
pgf2 >= 2,
cgi >= 3001.1.7.3,
exceptions,
json >= 0.3.3,
utf8-string >= 0.3.1.1,
bytestring
if os(windows)
ghc-options: -optl-mwindows
else
build-depends: unix