summaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/PGFService.hs64
-rw-r--r--src/server/RunHTTP.hs41
-rw-r--r--src/server/ServeStaticFile.hs20
-rw-r--r--src/server/gf-server.cabal4
4 files changed, 114 insertions, 15 deletions
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index c19f7961c..4d8cd2f51 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -5,6 +5,8 @@ import qualified PGF
import Cache
import FastCGIUtils
import URLEncoding
+import RunHTTP
+import ServeStaticFile
import Network.FastCGI
import Text.JSON
@@ -25,6 +27,7 @@ import System.FilePath
import System.Process
import System.Exit
import System.IO
+import System.Environment(getArgs)
logFile :: FilePath
logFile = "pgf-error.log"
@@ -33,33 +36,64 @@ logFile = "pgf-error.log"
main :: IO ()
main = do stderrToFile logFile
cache <- newCache PGF.readPGF
+ args <- getArgs
+ case args of
+ [] -> fcgiMain cache
+ ["http"] -> httpMain cache 41296
+ ["http",port] -> httpMain cache =<< readIO port
+
+httpMain cache port = runHTTP port (do log ; serve =<< getPath)
+ where
+ log = do method <- requestMethod
+ uri <- getVarWithDefault "REQUEST_URI" "-"
+ logCGI $ method++" "++uri
+
+ serve path =
+ 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
+
+fcgiMain :: Cache PGF -> IO ()
+fcgiMain cache =
#ifndef mingw32_HOST_OS
- runFastCGIConcurrent' forkIO 100 (handleErrors (handleCGIErrors (cgiMain cache)))
+ runFastCGIConcurrent' forkIO 100 (cgiMain cache)
#else
- runFastCGI (handleErrors (handleCGIErrors (cgiMain cache)))
+ runFastCGI (cgiMain cache)
#endif
+getPath = getVarWithDefault "SCRIPT_FILENAME" ""
+
cgiMain :: Cache PGF -> CGI CGIResult
-cgiMain cache =
- do path <- getVarWithDefault "SCRIPT_FILENAME" ""
- pgf <- liftIO $ readCache cache path
+cgiMain cache = cgiMain' cache =<< getPath
+
+cgiMain' :: Cache PGF -> FilePath -> CGI CGIResult
+cgiMain' cache path =
+ handleErrors . handleCGIErrors $
+ do pgf <- liftIO $ readCache cache path
command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString)) (getInput "command")
pgfMain pgf command
pgfMain :: PGF -> String -> CGI CGIResult
pgfMain pgf command =
case command of
- "parse" -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom >>= outputJSONP
- "complete" -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit >>= outputJSONP
- "linearize" -> return (doLinearize pgf) `ap` getTree `ap` getTo >>= outputJSONP
+ "parse" -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom
+ "complete" -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit
+ "linearize" -> outputJSONP =<< doLinearize pgf `fmap` getTree `ap` getTo
"random" -> getCat >>= \c -> getLimit >>= liftIO . doRandom pgf c >>= outputJSONP
- "translate" -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo >>= outputJSONP
- "translategroup" -> return (doTranslateGroup pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo >>= outputJSONP
- "grammar" -> return (doGrammar pgf) `ap` requestAcceptLanguage >>= outputJSONP
- "abstrtree" -> getTree >>= liftIO . doGraphvizAbstrTree pgf >>= outputPNG
+ "translate" -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
+ "translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
+ "grammar" -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage
+ "abstrtree" -> outputPNG =<< liftIO . doGraphvizAbstrTree pgf =<< getTree
"parsetree" -> getTree >>= \t -> getFrom >>= \(Just l) -> liftIO (doGraphvizParseTree pgf l t) >>= outputPNG
"alignment" -> getTree >>= liftIO . doGraphvizAlignment pgf >>= outputPNG
- "browse" -> return (doBrowse pgf) `ap` getId `ap` getCSSClass `ap` getHRef >>= outputHTML
+ "browse" -> outputHTML =<< doBrowse pgf `fmap` getId `ap` getCSSClass `ap` getHRef
_ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command]
where
getText :: CGI String
@@ -447,5 +481,5 @@ langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languag
-- * General utilities
-cleanFilePath :: FilePath -> FilePath
-cleanFilePath = takeFileName
+--cleanFilePath :: FilePath -> FilePath
+--cleanFilePath = takeFileName
diff --git a/src/server/RunHTTP.hs b/src/server/RunHTTP.hs
new file mode 100644
index 000000000..cf536d054
--- /dev/null
+++ b/src/server/RunHTTP.hs
@@ -0,0 +1,41 @@
+module RunHTTP(runHTTP) where
+import Network.URI(uriPath,uriQuery)
+import Network.CGI(ContentType(..))
+import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..),
+ Headers,HeaderName(..))
+import Network.CGI.Monad(runCGIT)
+import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments)
+import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack)
+import qualified Data.Map as M(fromList)
+
+documentRoot = "www"
+
+runHTTP port = initServer port . cgiHandler
+
+cgiHandler h = fmap httpResp . runCGIT h . cgiReq
+
+httpResp :: (Headers,CGIResult) -> Response
+httpResp (hdrs,r) = Response code (map name hdrs) (body r)
+ where
+ code = maybe 200 (read.head.words) (lookup (HeaderName "Status") hdrs)
+ body CGINothing = ""
+ body (CGIOutput s) = BS.unpack s
+
+ name (HeaderName n,v) = (n,v)
+
+cgiReq :: Request -> CGIRequest
+cgiReq (Request method uri hdrs body) = CGIRequest vars inputs body'
+ where
+ vars = M.fromList [("REQUEST_METHOD",method),
+ ("REQUEST_URI",show uri),
+ ("SCRIPT_FILENAME",documentRoot++uriPath uri),
+ ("QUERY_STRING",qs)]
+ qs = case uriQuery uri of
+ '?':s -> s
+ s -> s
+ inputs = map input $ queryToArguments qs -- assumes method=="GET"
+ body' = BS.pack body
+
+ input (name,val) = (name,Input (BS.pack val) Nothing plaintext)
+ plaintext = ContentType "plain" "text" []
+ \ No newline at end of file
diff --git a/src/server/ServeStaticFile.hs b/src/server/ServeStaticFile.hs
new file mode 100644
index 000000000..f2bbc3e81
--- /dev/null
+++ b/src/server/ServeStaticFile.hs
@@ -0,0 +1,20 @@
+module ServeStaticFile where
+import System.FilePath
+import Network.CGI(setHeader,outputFPS,liftIO)
+import qualified Data.ByteString.Lazy.Char8 as BS
+
+serveStaticFile path =
+ do setHeader "Content-Type" (contentTypeFromExt (takeExtension path))
+ outputFPS =<< liftIO (BS.readFile path)
+
+contentTypeFromExt ext =
+ case ext of
+ ".html" -> "text/html; charset=\"iso8859-1\""
+ ".htm" -> "text/html; charset=\"iso8859-1\""
+ ".xml" -> "text/xml; charset=\"iso8859-1\""
+ ".txt" -> "text/plain; charset=\"iso8859-1\""
+ ".css" -> "text/css; charset=\"iso8859-1\""
+ ".js" -> "text/javascript; charset=\"iso8859-1\""
+ ".png" -> "image/png"
+ ".jpg" -> "image/jpg"
+ _ -> "application/octet-stream" \ No newline at end of file
diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal
index fa576db4e..619efdde1 100644
--- a/src/server/gf-server.cabal
+++ b/src/server/gf-server.cabal
@@ -16,6 +16,8 @@ executable pgf-server
gf >= 3.1,
cgi >= 3001.1.8.0,
fastcgi >= 3001.0.2.2,
+ httpd-shed,
+ network,
json >= 0.3.3,
utf8-string >= 0.3.1.1,
bytestring,
@@ -27,6 +29,8 @@ executable pgf-server
FastCGIUtils
Cache
URLEncoding
+ RunHTTP
+ ServeStaticFile
ghc-options: -threaded
if os(windows)
ghc-options: -optl-mwindows
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:15:56 +0000