diff --git a/Makefile b/Makefile index 9190c6a11..09872fd1c 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index 8c468003c..cd1dde57a 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -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" diff --git a/src/compiler/GF/Server/CGI.hs b/src/compiler/GF/Server/CGI.hs deleted file mode 100644 index 36455c3c6..000000000 --- a/src/compiler/GF/Server/CGI.hs +++ /dev/null @@ -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) diff --git a/src/compiler/GF/Server/RunHTTP.hs b/src/compiler/GF/Server/RunHTTP.hs index 09e338ae4..b353fe2ea 100644 --- a/src/compiler/GF/Server/RunHTTP.hs +++ b/src/compiler/GF/Server/RunHTTP.hs @@ -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) diff --git a/src/compiler/GF/Server/ServeStaticFile.hs b/src/compiler/GF/Server/ServeStaticFile.hs deleted file mode 100644 index 9e3b8a19a..000000000 --- a/src/compiler/GF/Server/ServeStaticFile.hs +++ /dev/null @@ -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" \ No newline at end of file diff --git a/src/compiler/GF/Server/Setup.hs b/src/compiler/GF/Server/Setup.hs deleted file mode 100644 index 1ef4756c0..000000000 --- a/src/compiler/GF/Server/Setup.hs +++ /dev/null @@ -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_dirpgf) - removeFile pgf - where - tmp_dir = gfo_dirtmp - 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_dirfile) - where - src = minibar_srcfile - - create_root_index = writeFile (www_dir"index.html") index_html - - index_html = "

PGF service

\n

Available demos

\n" - ++"" - ++"Additional grammars can be installed in" - ++"
"++grammars_dir++"
" - ++"" - ++"Grammatical Framework" -execute command = - do putStrLn command - e <- system command - case e of - ExitSuccess -> return () - _ -> fail "Command failed" - return () diff --git a/src/compiler/GF/Server/exec/pgf-http.hs b/src/compiler/GF/Server/exec/pgf-http.hs deleted file mode 100644 index 38ea588ff..000000000 --- a/src/compiler/GF/Server/exec/pgf-http.hs +++ /dev/null @@ -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 diff --git a/src/compiler/GF/Server/gf-server-jsapi.js b/src/compiler/GF/Server/gf-server-jsapi.js deleted file mode 100644 index 2b5037bd0..000000000 --- a/src/compiler/GF/Server/gf-server-jsapi.js +++ /dev/null @@ -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+")"); -}; diff --git a/src/compiler/GF/Server/simple-client.html b/src/compiler/GF/Server/simple-client.html deleted file mode 100644 index a525f99f8..000000000 --- a/src/compiler/GF/Server/simple-client.html +++ /dev/null @@ -1,111 +0,0 @@ - - - - - - - - - - - - AJAX GF Translator - - -
-
-

- -

-

- - - - - -

-
-
-
-
- - diff --git a/src/compiler/GF/Server/transfer/Fold.hs b/src/compiler/GF/Server/transfer/Fold.hs deleted file mode 100644 index aedd655eb..000000000 --- a/src/compiler/GF/Server/transfer/Fold.hs +++ /dev/null @@ -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 diff --git a/src/compiler/GF/Server/translator.css b/src/compiler/GF/Server/translator.css deleted file mode 100644 index 6ca26d825..000000000 --- a/src/compiler/GF/Server/translator.css +++ /dev/null @@ -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; -} - diff --git a/src/compiler/GF/Server/translator.js b/src/compiler/GF/Server/translator.js deleted file mode 100644 index 73c3dd5e2..000000000 --- a/src/compiler/GF/Server/translator.js +++ /dev/null @@ -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); - } -} diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal index c2a5c5576..bdfdfbb85 100644 --- a/src/compiler/gf.cabal +++ b/src/compiler/gf.cabal @@ -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 diff --git a/src/compiler/GF/Server/CGIUtils.hs b/src/server/CGIUtils.hs similarity index 87% rename from src/compiler/GF/Server/CGIUtils.hs rename to src/server/CGIUtils.hs index 07981a717..f47e3eceb 100644 --- a/src/compiler/GF/Server/CGIUtils.hs +++ b/src/server/CGIUtils.hs @@ -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 diff --git a/src/compiler/GF/Infra/Cache.hs b/src/server/Cache.hs similarity index 96% rename from src/compiler/GF/Infra/Cache.hs rename to src/server/Cache.hs index c40f6f0f0..85c84df36 100644 --- a/src/compiler/GF/Infra/Cache.hs +++ b/src/server/Cache.hs @@ -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) diff --git a/src/compiler/GF/Server/LICENSE b/src/server/LICENSE similarity index 100% rename from src/compiler/GF/Server/LICENSE rename to src/server/LICENSE diff --git a/src/compiler/GF/Server/PGFService.hs b/src/server/PGFService.hs similarity index 78% rename from src/compiler/GF/Server/PGFService.hs rename to src/server/PGFService.hs index 3e2d2ef41..04d576168 100644 --- a/src/compiler/GF/Server/PGFService.hs +++ b/src/server/PGFService.hs @@ -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=< 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 = diff --git a/src/compiler/GF/Server/URLEncoding.hs b/src/server/URLEncoding.hs similarity index 96% rename from src/compiler/GF/Server/URLEncoding.hs rename to src/server/URLEncoding.hs index ac9f75a21..1a8f579b2 100644 --- a/src/compiler/GF/Server/URLEncoding.hs +++ b/src/server/URLEncoding.hs @@ -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) diff --git a/src/compiler/GF/Server/lighttpd.conf b/src/server/lighttpd.conf similarity index 93% rename from src/compiler/GF/Server/lighttpd.conf rename to src/server/lighttpd.conf index 88a016513..13514a209 100644 --- a/src/compiler/GF/Server/lighttpd.conf +++ b/src/server/lighttpd.conf @@ -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" )) ) diff --git a/src/compiler/GF/Server/exec/pgf-fcgi.hs b/src/server/pgf-fcgi.hs similarity index 85% rename from src/compiler/GF/Server/exec/pgf-fcgi.hs rename to src/server/pgf-fcgi.hs index 5fe43e0d4..9fddeed89 100644 --- a/src/compiler/GF/Server/exec/pgf-fcgi.hs +++ b/src/server/pgf-fcgi.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} import Control.Concurrent(forkIO) -import Network.FastCGI(runFastCGI,runFastCGIConcurrent') +import Network.FastCGI import PGFService(cgiMain,newPGFCache,stderrToFile,logFile) diff --git a/src/server/pgf-service.cabal b/src/server/pgf-service.cabal new file mode 100644 index 000000000..d8bc842d0 --- /dev/null +++ b/src/server/pgf-service.cabal @@ -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