diff --git a/src/server/MainFastCGI.hs b/src/server/MainFastCGI.hs index 88178b017..d678c1579 100644 --- a/src/server/MainFastCGI.hs +++ b/src/server/MainFastCGI.hs @@ -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."