msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Added parse and linearize functions to the fastcgi server. Some refactoring.

Browse Source
This commit is contained in:
bjorn
2008-08-19 08:13:51 +00:00
parent 1510e08209
commit 9f9bb2d5b7
1 changed files with 67 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

114
src/server/MainFastCGI.hs
View File

@@ -12,20 +12,12 @@ import Control.Exception
import Control.Monad
import Data.Dynamic
import Data.Maybe
import Data.List
grammarFile :: FilePath
grammarFile = "grammar.pgf"
newtype Record a = Record { unRecord :: [(String,a)] }
type Translation = Record [Record String]
instance JSON a => JSON (Record a) where
readJSON = fmap (Record . fromJSObject) . readJSON
showJSON = showJSON . toJSObject . unRecord
main :: IO ()
main = do initFastCGI
@@ -38,47 +30,70 @@ fcgiMain ref = getData PGF.readPGF ref grammarFile >>= cgiMain
cgiMain :: PGF -> CGI CGIResult
cgiMain pgf =
do path <- pathInfo
case path of
"/translate" -> do input <- liftM (fromMaybe "") $ getInput "input"
mcat <- getCat pgf "cat"
mfrom <- getLang pgf "from"
mto <- getLang pgf "to"
outputJSON $ translate pgf input mcat mfrom mto
"/categories" -> outputJSON $ PGF.categories pgf
"/languages" -> outputJSON $ toJSObject $ listLanguages pgf
_ -> outputNotFound path
json <- case path of
"/parse" -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom
"/linearize" -> return (doLinearize pgf) `ap` getTree `ap` getTo
"/translate" -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo
"/categories" -> return $ doCategories pgf
"/languages" -> return $ doLanguages pgf
_ -> throwCGIError 404 "Not Found" ["Resource not found: " ++ path]
outputJSON json
where
getText :: CGI String
getText = liftM (fromMaybe "") $ getInput "input"
getCat :: PGF -> String -> CGI (Maybe PGF.Category)
getCat pgf i =
do mcat <- getInput i
case mcat of
Just "" -> return Nothing
Just cat | cat `notElem` PGF.categories pgf ->
throwCGIError 400 "Unknown category" ["Unknown category: " ++ cat]
_ -> return mcat
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)
getLang :: PGF -> String -> CGI (Maybe PGF.Language)
getLang pgf i =
do mlang <- getInput i
case mlang of
Just "" -> return Nothing
Just lang | lang `notElem` PGF.languages pgf ->
throwCGIError 400 "Unknown language" ["Unknown language: " ++ lang]
_ -> return mlang
getCat :: CGI (Maybe PGF.Category)
getCat =
do mcat <- getInput "cat"
case mcat of
Just "" -> return Nothing
Just cat | cat `notElem` PGF.categories pgf ->
throwCGIError 400 "Unknown category" ["Unknown category: " ++ cat]
_ -> return mcat
outputJSON :: JSON a => a -> CGI CGIResult
outputJSON x = do setHeader "Content-Type" "text/json; charset=utf-8"
outputStrict $ UTF8.encodeString $ encode x
getFrom :: CGI (Maybe PGF.Language)
getFrom = getLang "from"
outputStrict :: String -> CGI CGIResult
outputStrict x | x == x = output x
| otherwise = fail "I am the pope."
getTo :: CGI (Maybe PGF.Language)
getTo = getLang "to"
translate :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> Maybe PGF.Language -> Translation
translate pgf input mcat mfrom mto =
Record [(from,[Record (linearize' pgf mto tree) | tree <- trees])
getLang :: String -> CGI (Maybe PGF.Language)
getLang i =
do mlang <- getInput i
case mlang of
Just "" -> return Nothing
Just lang | lang `notElem` PGF.languages pgf ->
throwCGIError 400 "Unknown language" ["Unknown language: " ++ lang]
_ -> return mlang
doTranslate :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue
doTranslate pgf input mcat mfrom mto = showJSON $ toJSObject $
[(from, [toJSObject (linearize' pgf mto tree) | tree <- trees])
| (from,trees) <- parse' pgf input mcat mfrom]
doParse :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> JSValue
doParse pgf input mcat mfrom = showJSON $ toJSObject $
[(from, map PGF.showTree trees) | (from,trees) <- parse' pgf input mcat mfrom]
doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue
doLinearize pgf tree mto = showJSON $ toJSObject $ linearize' pgf mto tree
doLanguages :: PGF -> JSValue
doLanguages pgf = showJSON $ toJSObject [(l,toJSObject (info l)) | l <- PGF.languages pgf]
where info l = [("languageCode", showJSON (fromMaybe "" (PGF.languageCode pgf l))),
("canParse", showJSON (PGF.canParse pgf l))]
doCategories :: PGF -> JSValue
doCategories pgf = showJSON (PGF.categories pgf)
-- * PGF utilities
parse' :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> [(PGF.Language,[PGF.Tree])]
parse' pgf input mcat mfrom =
case mfrom of
@@ -92,11 +107,6 @@ linearize' pgf mto tree =
Nothing -> PGF.linearizeAllLang pgf tree
Just to -> [(to,PGF.linearize pgf to tree)]
listLanguages :: PGF -> [(PGF.Language,JSObject JSValue)]
listLanguages pgf = [(l,toJSObject (info l)) | l <- sort (PGF.languages pgf)]
where info l = [("languageCode", showJSON (fromMaybe "" (PGF.languageCode pgf l))),
("canParse", showJSON (PGF.canParse pgf l))]
-- * General CGI Error exception mechanism
data CGIError = CGIError { cgiErrorCode :: Int, cgiErrorMessage :: String, cgiErrorText :: [String] }
@@ -111,3 +121,13 @@ handleCGIErrors x = x `catchCGI` \e -> case e of
Nothing -> throw e
Just (CGIError c m t) -> outputError c m t
_ -> throw e
-- * General CGI and JSON stuff
outputJSON :: JSON a => a -> CGI CGIResult
outputJSON x = do setHeader "Content-Type" "text/json; charset=utf-8"
outputStrict $ UTF8.encodeString $ encode x
outputStrict :: String -> CGI CGIResult
outputStrict x | x == x = output x
| otherwise = fail "I am the pope."