GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -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)
CMD_PFX=v1-
endif
CMD_OPT="--force-reinstalls"
endif
all: src/runtime/c/libpgf.la src/runtime/haskell/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
all: src/runtime/c/libpgf.la src/runtime/haskell/dist/setup-config src/server/dist/setup-config src/compiler/dist/setup-config
src/runtime/c/libpgf.la: src/runtime/c/Makefile
(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)
src/runtime/haskell/dist/setup-config: src/runtime/c/libpgf.la src/runtime/haskell/pgf2.cabal
ifneq ($(STACK),1)
(cd src/runtime/haskell; cabal ${CMD_PFX}configure)
endif
(cd src/runtime/haskell; ${CMD} ${CMD_PFX}install ${CMD_OPT})
src/compiler/dist/setup-config: src/compiler/gf.cabal src/compiler/Setup.hs src/compiler/WebSetup.hs
ifneq ($(STACK),1)
(cd src/compiler; cabal ${CMD_PFX}configure)
endif
src/server/dist/setup-config: src/server/pgf-service.cabal src/runtime/haskell/dist/setup-config
(cd src/server; ${CMD} ${CMD_PFX}install ${CMD_OPT})
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:
${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 qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
import Network.CGI(handleErrors,liftIO)
import GF.Server.CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
import CGIUtils(handleCGIErrors)
import Text.JSON(encode,showJSON,makeObj)
--import System.IO.Silently(hCapture)
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.SIO(captureSIO)
import GF.Data.Utilities(apSnd,mapSnd)
import qualified GF.Server.PGFService as PS
import qualified PGFService as PS
import Data.Version(showVersion)
import Paths_gf(getDataDir,version)
import GF.Infra.BuildInfo (buildInfo)
import GF.Server.SimpleEditor.Convert(parseModule)
import GF.Server.RunHTTP(cgiHandler)
import GF.Server.URLEncoding(decodeQuery)
import URLEncoding(decodeQuery)
--logFile :: FilePath
--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
import GF.Server.CGI(ContentType(..),
CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..),
runCGIT)
import GF.Server.URLEncoding(decodeQuery)
import Network.CGI(ContentType(..))
import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..))
import Network.CGI.Monad(runCGIT)
import URLEncoding(decodeQuery)
import Network.URI(uriPath,uriQuery)
import Network.Shed.Httpd(initServer,Request(..),Response(..))
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.Location
GF.Infra.SIO
GF.Infra.Cache
GF.JavaScript.AbsJS
GF.JavaScript.PrintJS
GF.Quiz
@@ -212,6 +211,7 @@ executable gf
if flag(server)
build-depends:
pgf-service,
cgi >= 3001.3.0.2 && < 3001.6,
httpd-shed >= 0.4.0 && < 0.5,
network>=2.3 && <3.2
@@ -226,14 +226,10 @@ executable gf
cpp-options: -DSERVER_MODE
other-modules:
GF.Server
GF.Server.PGFService
GF.Server.RunHTTP
GF.Server.SimpleEditor.Convert
GF.Server.SimpleEditor.JSON
GF.Server.SimpleEditor.Syntax
GF.Server.URLEncoding
GF.Server.CGI
GF.Server.CGIUtils
if flag(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 #-}
-- | CGI utility functions for output, error handling and logging
module GF.Server.CGIUtils (throwCGIError, handleCGIErrors,
stderrToFile,logError,
outputJSONP,outputEncodedJSONP,
outputPNG,outputBinary,outputBinary',
outputHTML,outputPlain,outputText) where
module CGIUtils (throwCGIError, handleCGIErrors,
stderrToFile,logError,
outputJSONP,outputEncodedJSONP,
outputPNG,outputBinary,outputBinary',
outputHTML,outputPlain,outputText) where
import Control.Exception(Exception(..),SomeException(..),throw)
import Data.Typeable(Typeable,cast)
@@ -14,14 +14,13 @@ import System.IO(hPutStrLn,stderr)
import System.Posix
#endif
import GF.Server.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
getInput)
import Network.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
getInput)
import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
import qualified Data.ByteString.Lazy as BS
import Control.Monad.Catch (MonadThrow(throwM))
import Network.CGI.Monad (catchCGI)
import Control.Monad.Catch (MonadCatch(catch))
-- * 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
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 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 #-}
module GF.Server.PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
module PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
import PGF2
import PGF2.Transactions
import GF.Text.Lexing
import GF.Infra.Cache
import GF.Server.CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
outputBinary,outputBinary',
logError,handleCGIErrors,throwCGIError,stderrToFile)
import GF.Server.CGI(CGI,readInput,getInput,getVarWithDefault,
CGIResult,requestAcceptLanguage,handleErrors,setHeader,
Accept(..),Language(..),negotiate,liftIO)
import GF.Server.URLEncoding
import Cache
import Network.CGI(CGI,readInput,getInput,getVarWithDefault,
CGIResult,handleErrors,setHeader,
Accept(..),Language(..),negotiate,liftIO)
import CGIUtils(outputJSONP,outputPlain,
outputBinary,outputBinary',
handleCGIErrors,throwCGIError,stderrToFile)
import URLEncoding
import Data.Time.Clock(UTCTime)
import Data.Time.Format(formatTime)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
#else
import System.Locale(defaultTimeLocale,rfc822DateFormat)
#endif
import Text.JSON
import Text.PrettyPrint as PP(render, text, (<+>))
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
import qualified Data.ByteString.Lazy as BS
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.State(State,evalState,get,put)
import Control.Monad.Catch(bracket_)
import Data.Char
--import Data.Function (on)
import Data.List ({-sortBy,-}intersperse,mapAccumL,nub,isSuffixOf,nubBy,stripPrefix)
import qualified Data.Map as Map
import Data.Maybe
import System.Random
import System.Process
import System.Exit
import System.IO
import System.IO.Error(isDoesNotExistError)
import System.Directory(removeFile)
import System.FilePath(takeExtension,dropExtension,takeDirectory,(</>),(<.>))
import System.FilePath(takeExtension)
import System.Mem(performGC)
catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
@@ -121,12 +109,12 @@ pgfMain qsem command (t,pgf) =
"linearizeAll" -> out t=<< linAll # tree % to
"translate" -> withQSem qsem $
out t=<<join(trans # input % cat % to % start % limit%treeopts)
"lookupmorpho" -> out t=<< morpho # from1 % textInput
"lookupcohorts" -> out t=<< cohorts # from1 % getInput "filter" % textInput
"lookupmorpho" -> out t=<< morpho # from % textInput
"lookupcohorts" -> out t=<< cohorts # from % getInput "filter" % textInput
"flush" -> out t=<< flush
"grammar" -> out t grammar
"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
_ -> badRequest "Unknown command" command
where
@@ -203,16 +191,16 @@ pgfMain qsem command (t,pgf) =
mkChartPArg (PArg _ fid) = showJSON fid
-}
linAll tree to = showJSON (linAll' tree to)
linAll' tree (tos,unlex) =
linAll' tree tos =
[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 (tos,unlex) =
[makeObj ["to".=to,"text".=unlex (linearize c tree)]|(to,c)<-tos]
lin' tree tos =
[makeObj ["to".=to,"text".=linearize c tree]|(to,c)<-tos]
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]
trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
@@ -251,17 +239,17 @@ pgfMain qsem command (t,pgf) =
(lookupCohorts concr input)]
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 =
showJSON
[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)
wordforword' inp@((from,concr),input) cat tos =
[(to,unwords $ map (lin_word' c) pws)
|let pws=map parse_word' (words input),(to,c)<-tos]
where
lin_word' c = either id (lin1 c)
@@ -294,21 +282,19 @@ pgfMain qsem command (t,pgf) =
---
input = lexit # from % textInput
where
lexit (from,lex) input = (from,lex input)
input = (,) # from % textInput
from = maybe (missing "from") getlexer =<< from'
where
getlexer f@(_,concr) = (,) f # c_lexer concr
from = maybe (missing "from") return =<< getLang "from"
from1 = maybe (missing "from") return =<< from'
from' = getLang "from"
to = getLangs "to"
to = (,) # getLangs "to" % unlexerC (const False)
getLangs i = mapM readLang . maybe [] words =<< getInput i
getLangs = getLangs' readLang
getLang = getLang' readLang
getLang i = do
mlang <- getInput i
case mlang of
Just lang@(_:_) -> Just # readLang lang
_ -> return Nothing
readLang :: String -> CGI (String,Concr)
readLang lang =
@@ -319,42 +305,6 @@ pgfMain qsem command (t,pgf) =
tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
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
setHeader "Last-Modified" fmt
@@ -367,15 +317,6 @@ nonEmpty r = r
textInput :: CGI String
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 = readInput "limit"
depth = readInput "depth"
@@ -401,7 +342,6 @@ throw code msg extra =
format def = maybe def id # getInput "format"
type From = (Maybe Concr,String)
type To = ([Concr],Unlexer)
type TreeOpts = (Bool,Bool) -- (trie,jsontree)
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.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" =>
((
"socket" => basedir + "/" + var.PID + "-pgf.socket",
"bin-path" => basedir + "/dist/build/pgf-service/pgf-service",
# Use 2 OS threads (to be able to use 2 cores).
# Limit heap size to 512 MB.
"bin-path" => basedir + "/dist/build/pgf-service/pgf-fcgi",
# Use 2 OS threads (to be able to use 2 cores).
# Limit heap size to 512 MB.
"bin-environment" => ("GHCRTS" => "-N2 -M512M"),
"min-procs" => 1,
"max-procs" => 1,
"broken-scriptfilename" => "disable",
"check-local" => "disable"
"check-local" => "disable"
)),
".fcgi" =>
((
@@ -72,7 +72,7 @@ fastcgi.server = (".pgf" =>
"min-procs" => 1,
"max-procs" => 1,
"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 #-}
import Control.Concurrent(forkIO)
import Network.FastCGI(runFastCGI,runFastCGIConcurrent')
import Network.FastCGI
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