From 55efa546a9349781e80db642b483b3d9c7f65c2e Mon Sep 17 00:00:00 2001 From: bjorn Date: Wed, 29 Oct 2008 19:49:38 +0000 Subject: Rename MainFastCGI.hs to PGFService.hs. --- src/server/MainFastCGI.hs | 156 --------------------------------------------- src/server/PGFService.hs | 156 +++++++++++++++++++++++++++++++++++++++++++++ src/server/gf-server.cabal | 2 +- 3 files changed, 157 insertions(+), 157 deletions(-) delete mode 100644 src/server/MainFastCGI.hs create mode 100644 src/server/PGFService.hs (limited to 'src') diff --git a/src/server/MainFastCGI.hs b/src/server/MainFastCGI.hs deleted file mode 100644 index 84fd3108e..000000000 --- a/src/server/MainFastCGI.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -import PGF (PGF) -import qualified PGF -import Cache -import FastCGIUtils -import URLEncoding - -import Network.FastCGI -import Text.JSON -import qualified Codec.Binary.UTF8.String as UTF8 (encodeString, decodeString) - -import Control.Concurrent -import Control.Monad -import Data.Char -import qualified Data.Map as Map -import Data.Maybe - - -main :: IO () -main = do initFastCGI - cache <- newCache PGF.readPGF - runFastCGIConcurrent' forkIO 100 (handleErrors (handleCGIErrors (cgiMain cache))) - -cgiMain :: Cache PGF -> CGI CGIResult -cgiMain cache = - do path <- pathInfo - case filter (not . null) $ splitBy (=='/') path of - [file,command] -> do pgf <- liftIO $ readCache cache file - json <- pgfMain pgf command - outputJSONP json - _ -> throwCGIError 400 "Unknown resource" ["Unknown resource: " ++ show path, - "Use /grammar.pgf/command"] - -pgfMain :: PGF -> String -> CGI JSValue -pgfMain pgf command = - case command of - "parse" -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom - "complete" -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit - "linearize" -> return (doLinearize pgf) `ap` getTree `ap` getTo - "translate" -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo - "grammar" -> return (doGrammar pgf) `ap` requestAcceptLanguage - _ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] - where - getText :: CGI String - getText = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" - - getTree :: CGI PGF.Tree - getTree = do mt <- getInput "tree" - t <- maybe (throwCGIError 400 "No tree given" ["No tree given"]) return mt - maybe (throwCGIError 400 "Bad tree" ["Bad tree: " ++ t]) return (PGF.readTree t) - - getCat :: CGI (Maybe PGF.Type) - getCat = - do mcat <- getInput "cat" - case mcat of - Nothing -> return Nothing - Just "" -> return Nothing - Just cat -> case PGF.readType cat of - Nothing -> throwCGIError 400 "Bad category" ["Bad category: " ++ cat] - Just typ | typ `elem` PGF.categories pgf -> return $ Just typ - | otherwise -> throwCGIError 400 "Unknown category" ["Unknown category: " ++ show typ] - - getFrom :: CGI (Maybe PGF.Language) - getFrom = getLang "from" - - getTo :: CGI (Maybe PGF.Language) - getTo = getLang "to" - - getLimit :: CGI (Maybe Int) - getLimit = readInput "limit" - - getLang :: String -> CGI (Maybe PGF.Language) - getLang i = - do mlang <- getInput i - case mlang of - Nothing -> return Nothing - Just "" -> return Nothing - Just l -> case PGF.readLanguage l of - Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l] - Just lang | lang `elem` PGF.languages pgf -> return $ Just lang - | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l] - -doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue -doTranslate pgf input mcat mfrom mto = showJSON $ map toJSObject - [[("from", PGF.showLanguage from),("to", PGF.showLanguage to),("text",output)] - | (from,trees) <- parse' pgf input mcat mfrom, - tree <- trees, - (to,output) <- linearize' pgf mto tree] - -doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> JSValue -doParse pgf input mcat mfrom = showJSON $ map toJSObject - [[("from", PGF.showLanguage from),("tree",PGF.showTree tree)] - | (from,trees) <- parse' pgf input mcat mfrom, - tree <- trees ] - -doComplete :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue -doComplete pgf input mcat mfrom mlimit = showJSON $ map toJSObject $ limit - [[("from", PGF.showLanguage from),("text",text)] - | (from,compls) <- complete' pgf input mcat mfrom, - text <- compls] - where - limit xs = maybe xs (\n -> take n xs) mlimit - -doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue -doLinearize pgf tree mto = showJSON $ map toJSObject - [[("to", PGF.showLanguage to),("text",text)] | (to,text) <- linearize' pgf mto tree] - -doGrammar :: PGF -> Maybe (Accept Language) -> JSValue -doGrammar pgf macc = showJSON $ toJSObject - [("name", showJSON (PGF.abstractName pgf)), - ("userLanguage", showJSON (selectLanguage pgf macc)), - ("categories", showJSON categories), - ("languages", showJSON languages)] - where languages = map toJSObject - [[("name", showJSON l), - ("languageCode", showJSON $ fromMaybe "" (PGF.languageCode pgf l)), - ("canParse", showJSON $ PGF.canParse pgf l)] - | l <- PGF.languages pgf] - categories = map toJSObject [[("cat", PGF.showType cat)] | cat <- PGF.categories pgf] - -instance JSON PGF.CId where - readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage - showJSON = showJSON . PGF.showLanguage - --- * PGF utilities - -parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,[PGF.Tree])] -parse' pgf input mcat mfrom = - [(from,ts) | from <- froms, PGF.canParse pgf from, let ts = PGF.parse pgf from cat input, not (null ts)] - where froms = maybe (PGF.languages pgf) (:[]) mfrom - cat = fromMaybe (PGF.startCat pgf) mcat - -complete' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,[String])] -complete' pgf input mcat mfrom = - [(from,ss) | from <- froms, PGF.canParse pgf from, let ss = PGF.complete pgf from cat input, not (null ss)] - where froms = maybe (PGF.languages pgf) (:[]) mfrom - cat = fromMaybe (PGF.startCat pgf) mcat - -linearize' :: PGF -> Maybe PGF.Language -> PGF.Tree -> [(PGF.Language,String)] -linearize' pgf mto tree = - case mto of - Nothing -> PGF.linearizeAllLang pgf tree - Just to -> [(to,PGF.linearize pgf to tree)] - -selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language -selectLanguage pgf macc = case acceptable of - [] -> case PGF.languages pgf of - [] -> error "No concrete syntaxes in PGF grammar." - l:_ -> l - Language c:_ -> fromJust (langCodeLanguage pgf c) - where langCodes = mapMaybe (PGF.languageCode pgf) (PGF.languages pgf) - acceptable = negotiate (map Language langCodes) macc - -langCodeLanguage :: PGF -> String -> Maybe PGF.Language -langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languageCode pgf l == Just code] diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs new file mode 100644 index 000000000..84fd3108e --- /dev/null +++ b/src/server/PGFService.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +import PGF (PGF) +import qualified PGF +import Cache +import FastCGIUtils +import URLEncoding + +import Network.FastCGI +import Text.JSON +import qualified Codec.Binary.UTF8.String as UTF8 (encodeString, decodeString) + +import Control.Concurrent +import Control.Monad +import Data.Char +import qualified Data.Map as Map +import Data.Maybe + + +main :: IO () +main = do initFastCGI + cache <- newCache PGF.readPGF + runFastCGIConcurrent' forkIO 100 (handleErrors (handleCGIErrors (cgiMain cache))) + +cgiMain :: Cache PGF -> CGI CGIResult +cgiMain cache = + do path <- pathInfo + case filter (not . null) $ splitBy (=='/') path of + [file,command] -> do pgf <- liftIO $ readCache cache file + json <- pgfMain pgf command + outputJSONP json + _ -> throwCGIError 400 "Unknown resource" ["Unknown resource: " ++ show path, + "Use /grammar.pgf/command"] + +pgfMain :: PGF -> String -> CGI JSValue +pgfMain pgf command = + case command of + "parse" -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom + "complete" -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit + "linearize" -> return (doLinearize pgf) `ap` getTree `ap` getTo + "translate" -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo + "grammar" -> return (doGrammar pgf) `ap` requestAcceptLanguage + _ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] + where + getText :: CGI String + getText = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" + + getTree :: CGI PGF.Tree + getTree = do mt <- getInput "tree" + t <- maybe (throwCGIError 400 "No tree given" ["No tree given"]) return mt + maybe (throwCGIError 400 "Bad tree" ["Bad tree: " ++ t]) return (PGF.readTree t) + + getCat :: CGI (Maybe PGF.Type) + getCat = + do mcat <- getInput "cat" + case mcat of + Nothing -> return Nothing + Just "" -> return Nothing + Just cat -> case PGF.readType cat of + Nothing -> throwCGIError 400 "Bad category" ["Bad category: " ++ cat] + Just typ | typ `elem` PGF.categories pgf -> return $ Just typ + | otherwise -> throwCGIError 400 "Unknown category" ["Unknown category: " ++ show typ] + + getFrom :: CGI (Maybe PGF.Language) + getFrom = getLang "from" + + getTo :: CGI (Maybe PGF.Language) + getTo = getLang "to" + + getLimit :: CGI (Maybe Int) + getLimit = readInput "limit" + + getLang :: String -> CGI (Maybe PGF.Language) + getLang i = + do mlang <- getInput i + case mlang of + Nothing -> return Nothing + Just "" -> return Nothing + Just l -> case PGF.readLanguage l of + Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l] + Just lang | lang `elem` PGF.languages pgf -> return $ Just lang + | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l] + +doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue +doTranslate pgf input mcat mfrom mto = showJSON $ map toJSObject + [[("from", PGF.showLanguage from),("to", PGF.showLanguage to),("text",output)] + | (from,trees) <- parse' pgf input mcat mfrom, + tree <- trees, + (to,output) <- linearize' pgf mto tree] + +doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> JSValue +doParse pgf input mcat mfrom = showJSON $ map toJSObject + [[("from", PGF.showLanguage from),("tree",PGF.showTree tree)] + | (from,trees) <- parse' pgf input mcat mfrom, + tree <- trees ] + +doComplete :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue +doComplete pgf input mcat mfrom mlimit = showJSON $ map toJSObject $ limit + [[("from", PGF.showLanguage from),("text",text)] + | (from,compls) <- complete' pgf input mcat mfrom, + text <- compls] + where + limit xs = maybe xs (\n -> take n xs) mlimit + +doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue +doLinearize pgf tree mto = showJSON $ map toJSObject + [[("to", PGF.showLanguage to),("text",text)] | (to,text) <- linearize' pgf mto tree] + +doGrammar :: PGF -> Maybe (Accept Language) -> JSValue +doGrammar pgf macc = showJSON $ toJSObject + [("name", showJSON (PGF.abstractName pgf)), + ("userLanguage", showJSON (selectLanguage pgf macc)), + ("categories", showJSON categories), + ("languages", showJSON languages)] + where languages = map toJSObject + [[("name", showJSON l), + ("languageCode", showJSON $ fromMaybe "" (PGF.languageCode pgf l)), + ("canParse", showJSON $ PGF.canParse pgf l)] + | l <- PGF.languages pgf] + categories = map toJSObject [[("cat", PGF.showType cat)] | cat <- PGF.categories pgf] + +instance JSON PGF.CId where + readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage + showJSON = showJSON . PGF.showLanguage + +-- * PGF utilities + +parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,[PGF.Tree])] +parse' pgf input mcat mfrom = + [(from,ts) | from <- froms, PGF.canParse pgf from, let ts = PGF.parse pgf from cat input, not (null ts)] + where froms = maybe (PGF.languages pgf) (:[]) mfrom + cat = fromMaybe (PGF.startCat pgf) mcat + +complete' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,[String])] +complete' pgf input mcat mfrom = + [(from,ss) | from <- froms, PGF.canParse pgf from, let ss = PGF.complete pgf from cat input, not (null ss)] + where froms = maybe (PGF.languages pgf) (:[]) mfrom + cat = fromMaybe (PGF.startCat pgf) mcat + +linearize' :: PGF -> Maybe PGF.Language -> PGF.Tree -> [(PGF.Language,String)] +linearize' pgf mto tree = + case mto of + Nothing -> PGF.linearizeAllLang pgf tree + Just to -> [(to,PGF.linearize pgf to tree)] + +selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language +selectLanguage pgf macc = case acceptable of + [] -> case PGF.languages pgf of + [] -> error "No concrete syntaxes in PGF grammar." + l:_ -> l + Language c:_ -> fromJust (langCodeLanguage pgf c) + where langCodes = mapMaybe (PGF.languageCode pgf) (PGF.languages pgf) + acceptable = negotiate (map Language langCodes) macc + +langCodeLanguage :: PGF -> String -> Maybe PGF.Language +langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languageCode pgf l == Just code] diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal index 0b42f9d90..3feebe323 100644 --- a/src/server/gf-server.cabal +++ b/src/server/gf-server.cabal @@ -17,7 +17,7 @@ executable pgf.fcgi fastcgi >= 3001.0.2.1, json >= 0.3.3, utf8-string >= 0.3.1.1 - main-is: MainFastCGI.hs + main-is: PGFService.hs other-modules: FastCGIUtils Cache -- cgit v1.2.3