forked from GitHub/gf-core
113 lines
4.1 KiB
Haskell
113 lines
4.1 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
import PGF (PGF)
|
|
import qualified PGF
|
|
import FastCGIUtils
|
|
|
|
import Network.CGI
|
|
import Text.JSON
|
|
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
|
|
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import Data.Dynamic
|
|
import Data.Maybe
|
|
|
|
|
|
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
|
|
r <- newDataRef
|
|
loopFastCGI (handleErrors (handleCGIErrors (fcgiMain r)))
|
|
|
|
fcgiMain :: DataRef PGF -> CGI CGIResult
|
|
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
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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."
|
|
|
|
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])
|
|
| (from,trees) <- parse' pgf input mcat mfrom]
|
|
|
|
parse' :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> [(PGF.Language,[PGF.Tree])]
|
|
parse' pgf input mcat mfrom =
|
|
case mfrom of
|
|
Nothing -> PGF.parseAllLang pgf cat input
|
|
Just from -> [(from, PGF.parse pgf from cat input)]
|
|
where 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)]
|
|
|
|
listLanguages :: PGF -> [(PGF.Language,JSObject JSValue)]
|
|
listLanguages pgf = [(l,toJSObject (info l)) | l <- 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] }
|
|
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
|