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

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
+       json <- case path of
-         "/translate" -> do input <- liftM (fromMaybe "") $ getInput "input"
+         "/parse"      -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom
-                            mcat  <- getCat pgf "cat"
+         "/linearize"  -> return (doLinearize pgf) `ap` getTree `ap` getTo
-                            mfrom <- getLang pgf "from"
+         "/translate"  -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo
-                            mto   <- getLang pgf "to"
+         "/categories" -> return $ doCategories pgf
-                            outputJSON $ translate pgf input mcat mfrom mto
+         "/languages"  -> return $ doLanguages pgf
-         "/categories" -> outputJSON $ PGF.categories pgf
+         _             -> throwCGIError 404 "Not Found" ["Resource not found: " ++ path]
-         "/languages"  -> outputJSON $ toJSObject $ listLanguages pgf
+       outputJSON json
-         _ -> outputNotFound path
+  where
+    getText :: CGI String
+    getText = liftM (fromMaybe "") $ getInput "input"
 
-getCat :: PGF -> String -> CGI (Maybe PGF.Category)
+    getTree :: CGI PGF.Tree
-getCat pgf i = 
+    getTree = do mt <- getInput "tree"
-    do mcat  <- getInput i
+                 t <- maybe (throwCGIError 400 "No tree given" ["No tree given"]) return mt
-       case mcat of
+                 maybe (throwCGIError 400 "Bad tree" ["Bad tree: " ++ t]) return (PGF.readTree t)
-         Just "" -> return Nothing
-         Just cat | cat `notElem` PGF.categories pgf ->
-                      throwCGIError 400 "Unknown category" ["Unknown category: " ++ cat]
-         _ -> return mcat
 
-getLang :: PGF -> String -> CGI (Maybe PGF.Language)
+    getCat :: CGI (Maybe PGF.Category)
-getLang pgf i = 
+    getCat = 
-    do mlang <- getInput i
+       do mcat  <- getInput "cat"
-       case mlang of
+          case mcat of
-         Just "" -> return Nothing
+            Just "" -> return Nothing
-         Just lang | lang `notElem` PGF.languages pgf ->
+            Just cat | cat `notElem` PGF.categories pgf ->
-                       throwCGIError 400 "Unknown language" ["Unknown language: " ++ lang]
+                         throwCGIError 400 "Unknown category" ["Unknown category: " ++ cat]
-         _ -> return mlang
+            _ -> return mcat
 
-outputJSON :: JSON a => a -> CGI CGIResult
+    getFrom :: CGI (Maybe PGF.Language)
-outputJSON x = do setHeader "Content-Type" "text/json; charset=utf-8"
+    getFrom = getLang "from"
-                  outputStrict $ UTF8.encodeString $ encode x
 
-outputStrict :: String -> CGI CGIResult
+    getTo :: CGI (Maybe PGF.Language)
-outputStrict x | x == x = output x
+    getTo = getLang "to"
-               | otherwise = fail "I am the pope."
 
-translate :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> Maybe PGF.Language -> Translation
+    getLang :: String -> CGI (Maybe PGF.Language)
-translate pgf input mcat mfrom mto = 
+    getLang i = 
-    Record [(from,[Record (linearize' pgf mto tree) | tree <- trees]) 
+       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."