diff --git a/src/server/MainFastCGI.hs b/src/server/MainFastCGI.hs index 7c02924d6..cd644c9ad 100644 --- a/src/server/MainFastCGI.hs +++ b/src/server/MainFastCGI.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} + import PGF import FastCGIUtils @@ -5,6 +7,9 @@ import Network.CGI hiding (Language) import Text.JSON import qualified Codec.Binary.UTF8.String as UTF8 (encodeString) +import Control.Exception +import Control.Monad +import Data.Dynamic import Data.Maybe @@ -23,7 +28,7 @@ instance JSON a => JSON (Record a) where main :: IO () main = do initFastCGI r <- newDataRef - loopFastCGI (fcgiMain r) + loopFastCGI (handleErrors (handleCGIErrors (fcgiMain r))) fcgiMain :: DataRef PGF -> CGI CGIResult fcgiMain ref = getData readPGF ref grammarFile >>= cgiMain @@ -32,22 +37,52 @@ cgiMain :: PGF -> CGI CGIResult cgiMain pgf = do path <- pathInfo case path of - "/translate" -> do input <- fmap (fromMaybe "") $ getInput "input" - mcat <- getInput "cat" + "/translate" -> do input <- liftM (fromMaybe "") $ getInput "input" + mcat <- getInput "cat" mfrom <- getInput "from" - mto <- getInput "to" + mto <- getInput "to" + maybe (return ()) (checkCategory pgf) mcat + maybe (return ()) (checkLanguage pgf) mfrom + maybe (return ()) (checkLanguage pgf) mto outputJSON $ translate pgf input mcat mfrom mto _ -> outputNotFound path outputJSON :: JSON a => a -> CGI CGIResult outputJSON x = do setHeader "Content-Type" "text/json; charset=utf-8" - output $ UTF8.encodeString $ encode x + outputStrict $ UTF8.encodeString $ encode x + +outputStrict :: String -> CGI CGIResult +outputStrict x | x == x = output x + | otherwise = fail "I am the pope." + +checkCategory :: PGF -> Category -> CGI () +checkCategory pgf cat = unless (cat `elem` categories pgf) $ + throwCGIError 400 "Unknown category" ["Unknown category: " ++ cat] + +checkLanguage :: PGF -> Category -> CGI () +checkLanguage pgf lang = unless (lang `elem` languages pgf) $ + throwCGIError 400 "Unknown language" ["Unknown language: " ++ lang] translate :: PGF -> String -> Maybe Category -> Maybe Language -> Maybe Language -> Translation translate pgf input mcat mfrom mto = - Record [(from, [Record [(to, linearize pgf to tree) | to <- toLangs] | tree <- parse pgf from cat input]) - | from <- fromLangs] + Record [(from, [Record [(to, linearize pgf to tree) | to <- toLangs] | tree <- trees]) + | from <- fromLangs, let trees = parse pgf from cat input, not (null trees)] where cat = fromMaybe (startCat pgf) mcat fromLangs = maybe (languages pgf) (:[]) mfrom - toLangs = maybe (languages pgf) (:[]) mfrom - \ No newline at end of file + toLangs = maybe (languages pgf) (:[]) mto + + +-- * General CGI Error exception mechanism + +data CGIError = CGIError { cgiErrorCode :: Int, cgiErrorMessage :: String, cgiErrorText :: [String] } + deriving Typeable + +throwCGIError :: Int -> String -> [String] -> CGI a +throwCGIError c m t = throwCGI $ DynException $ toDyn $ CGIError c m t + +handleCGIErrors :: CGI CGIResult -> CGI CGIResult +handleCGIErrors x = x `catchCGI` \e -> case e of + DynException d -> case fromDynamic d of + Nothing -> throw e + Just (CGIError c m t) -> outputError c m t + _ -> throw e