1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
{-# 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
|
