summaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/CGI.hs2
-rw-r--r--src/server/CGIUtils.hs9
-rw-r--r--src/server/PGFService.hs62
3 files changed, 58 insertions, 15 deletions
diff --git a/src/server/CGI.hs b/src/server/CGI.hs
index 1a77351e2..821f93b9c 100644
--- a/src/server/CGI.hs
+++ b/src/server/CGI.hs
@@ -4,7 +4,7 @@ import Network.CGI as C(
CGI,ContentType(..),Accept(..),Language(..),
getVarWithDefault,readInput,negotiate,requestAcceptLanguage,getInput,
setHeader,output,outputFPS,outputError,
- handleErrors,catchCGI,throwCGI,
+ handleErrors,
liftIO)
import Network.CGI.Protocol as C(CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..))
diff --git a/src/server/CGIUtils.hs b/src/server/CGIUtils.hs
index 04bb8f22c..3c5ce2274 100644
--- a/src/server/CGIUtils.hs
+++ b/src/server/CGIUtils.hs
@@ -15,11 +15,14 @@ import System.Posix
#endif
import CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
- getInput,catchCGI,throwCGI)
+ getInput)
import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
import qualified Data.ByteString.Lazy as BS
+import Control.Monad.Catch (MonadThrow(throwM))
+import Network.CGI.Monad (catchCGI)
+import Control.Monad.Catch (MonadCatch(catch))
-- * Logging
@@ -53,11 +56,11 @@ instance Exception CGIError where
fromException (SomeException e) = cast e
throwCGIError :: Int -> String -> [String] -> CGI a
-throwCGIError c m t = throwCGI $ toException $ CGIError c m t
+throwCGIError c m t = throwM $ toException $ CGIError c m t
handleCGIErrors :: CGI CGIResult -> CGI CGIResult
handleCGIErrors x =
- x `catchCGI` \e -> case fromException e of
+ x `catch` \e -> case fromException e of
Nothing -> throw e
Just (CGIError c m t) -> do setXO; outputError c m t
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 5817be7f0..260c2e278 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -151,27 +151,37 @@ getFile get path =
cpgfMain qsem command (t,(pgf,pc)) =
case command of
"c-parse" -> withQSem qsem $
- out t=<< join (parse # input % start % limit % treeopts)
+ out t=<< join (parse # input % cat % start % limit % treeopts)
+ "c-parseToChart"-> withQSem qsem $
+ out t=<< join (parseToChart # input % cat % limit)
"c-linearize" -> out t=<< lin # tree % to
"c-bracketedLinearize"
-> out t=<< bracketedLin # tree % to
"c-linearizeAll"-> out t=<< linAll # tree % to
"c-translate" -> withQSem qsem $
- out t=<<join(trans # input % to % start % limit%treeopts)
+ out t=<<join(trans # input % cat % to % start % limit%treeopts)
"c-lookupmorpho"-> out t=<< morpho # from1 % textInput
"c-lookupcohorts"->out t=<< cohorts # from1 % getInput "filter" % textInput
"c-flush" -> out t=<< flush
"c-grammar" -> out t grammar
"c-abstrtree" -> outputGraphviz=<< C.graphvizAbstractTree pgf C.graphvizDefaults # tree
"c-parsetree" -> outputGraphviz=<< (\cnc -> C.graphvizParseTree cnc C.graphvizDefaults) . snd # from1 %tree
- "c-wordforword" -> out t =<< wordforword # input % to
+ "c-wordforword" -> out t =<< wordforword # input % cat % to
_ -> badRequest "Unknown command" command
where
flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
performGC
return $ showJSON ()
- cat = C.startCat pgf
+ cat :: CGI C.Type
+ cat =
+ do mcat <- getInput1 "cat"
+ case mcat of
+ Nothing -> return (C.startCat pgf)
+ Just cat -> case C.readType cat of
+ Nothing -> badRequest "Bad category" cat
+ Just typ -> return typ
+
langs = C.languages pgf
grammar = showJSON $ makeObj
@@ -182,8 +192,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
where
languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
- parse input@((from,_),_) start mlimit (trie,json) =
- do r <- parse' start mlimit input
+ parse input@((from,_),_) cat start mlimit (trie,json) =
+ do r <- parse' cat start mlimit input
return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
jsonParseResult json = either bad good
@@ -193,7 +203,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
-- Without caching parse results:
- parse' start mlimit ((from,concr),input) =
+ parse' cat start mlimit ((from,concr),input) =
case C.parseWithHeuristics concr cat input (-1) callbacks of
C.ParseOk ts -> return (Right (maybe id take mlimit (drop start ts)))
C.ParseFailed _ tok -> return (Left tok)
@@ -218,6 +228,35 @@ cpgfMain qsem command (t,(pgf,pc)) =
purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing
-- remove unused parse results after 2 minutes
-}
+
+ parseToChart ((from,concr),input) cat mlimit =
+ do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
+ C.ParseOk chart -> return (good chart)
+ C.ParseFailed _ tok -> return (bad tok)
+ C.ParseIncomplete -> return (bad "")
+ return $ showJSON [makeObj ("from".=from:r)]
+ where
+ callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
+ cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
+
+ bad err = ["parseFailed".=err]
+ good (roots,chart) = ["roots".=showJSON roots,
+ "chart".=makeObj [show fid .= mkChartObj inf | (fid,inf)<-Map.toList chart]]
+
+ mkChartObj (brackets,prods,cat) =
+ makeObj ["brackets".=map mkChartBracket brackets
+ ,"prods" .=map mkChartProd prods
+ ,"cat" .=cat
+ ]
+
+ mkChartBracket (s,e,ann) =
+ makeObj ["start".=s,"end".=e,"ann".=ann]
+
+ mkChartProd (expr,args,prob) =
+ makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob]
+
+ mkChartPArg (C.PArg _ fid) = showJSON fid
+
linAll tree to = showJSON (linAll' tree to)
linAll' tree (tos,unlex) =
[makeObj ["to".=to,
@@ -231,8 +270,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
bracketedLin' tree (tos,unlex) =
[makeObj ["to".=to,"brackets".=showJSON (C.bracketedLinearize c tree)]|(to,c)<-tos]
- trans input@((from,_),_) to start mlimit (trie,jsontree) =
- do parses <- parse' start mlimit input
+ trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
+ do parses <- parse' cat start mlimit input
return $
showJSON [ makeObj ["from".=from,
"translations".= jsonParses parses]]
@@ -266,7 +305,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
_ -> id)
(C.lookupCohorts concr input)]
- wordforword input@((from,_),_) = jsonWFW from . wordforword' input
+ wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
jsonWFW from rs =
showJSON
@@ -276,7 +315,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
[makeObj["to".=to,"text".=text]
| (to,text)<-rs]]]]]
- wordforword' inp@((from,concr),input) (tos,unlex) =
+ wordforword' inp@((from,concr),input) cat (tos,unlex) =
[(to,unlex . unwords $ map (lin_word' c) pws)
|let pws=map parse_word' (words input),(to,c)<-tos]
where
@@ -993,6 +1032,7 @@ instance JSON PGF.Trie where
showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf
-- showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts]
+ readJSON = error "PGF.Trie.readJSON intentionally not defined"
instance JSON PGF.CId where
readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
generated by cgit v1.2.3 (git 2.39.1) at 2026-08-04 18:45:58 +0000