From d1da0e06de1d50e5246ea362ea8f2949b6a2a950 Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 9 Apr 2014 17:51:25 +0000 Subject: [PATCH] PGF web service: add unlexers and enable client side caching Most PGF web API commands that produce linearizations now accept an unlexer parameter. Possible values are "text", "code" and "mixed". The web service now include Date and Last-Modified headers in the HTTP, responses. This means that browsers can treat responses as static content and cache them, so it becomes less critical to cache parse results in the server. Also did some cleanup in PGFService.hs, e.g. removed a couple of functions that can now be imported from PGF.Lexing instead. --- src/compiler/GFServer.hs | 9 +- src/server/Cache.hs | 9 +- src/server/PGFService.hs | 198 +++++++++++++++++++++------------------ 3 files changed, 123 insertions(+), 93 deletions(-) diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index cad43a97d..049b60d26 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -15,7 +15,7 @@ import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory, setCurrentDirectory,getCurrentDirectory, getDirectoryContents,removeFile,removeDirectory, getModificationTime) -import Data.Time (formatTime) +import Data.Time (getCurrentTime,formatTime) import System.Locale(defaultTimeLocale,rfc822DateFormat) import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory, ()) @@ -132,6 +132,7 @@ hmbracket_ pre post m = -- | HTTP request handler handle logLn documentroot state0 cache execute1 stateVar rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) = + addDate $ case method of "POST" -> normal_request (utf8inputs body) "GET" -> normal_request (utf8inputs q) @@ -140,6 +141,12 @@ handle logLn documentroot state0 cache execute1 stateVar logPutStrLn msg = liftIO $ logLn msg debug msg = logPutStrLn msg + addDate m = + do t <- getCurrentTime + r <- m + let fmt = formatTime defaultTimeLocale rfc822DateFormat t + return r{resHeaders=("Date",fmt):resHeaders r} + normal_request qs = do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs) let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s) diff --git a/src/server/Cache.hs b/src/server/Cache.hs index 8cb9135e2..d7c806783 100644 --- a/src/server/Cache.hs +++ b/src/server/Cache.hs @@ -1,4 +1,4 @@ -module Cache (Cache,newCache,flushCache,readCache) where +module Cache (Cache,newCache,flushCache,readCache,readCache') where import Control.Concurrent.MVar import Data.Map (Map) @@ -21,7 +21,10 @@ flushCache :: Cache a -> IO () flushCache c = modifyMVar_ (cacheObjects c) (const (return Map.empty)) readCache :: Cache a -> FilePath -> IO a -readCache c file = +readCache c file = snd `fmap` readCache' c file + +readCache' :: Cache a -> FilePath -> IO (UTCTime,a) +readCache' c file = do v <- modifyMVar (cacheObjects c) findEntry modifyMVar v readObject where @@ -35,4 +38,4 @@ readCache c file = x' <- case m of Just (t,x) | t' == t -> return x _ -> cacheLoad c file - return (Just (t',x'), x') + return (Just (t',x'), (t',x')) diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 24547bfd0..3918bc9e5 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -15,6 +15,8 @@ import qualified PGF2 as C import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime) #endif +import Data.Time.Format(formatTime) +import System.Locale(defaultTimeLocale,rfc822DateFormat) import Network.CGI import Text.JSON import Text.PrettyPrint as PP(render, text, (<+>)) @@ -80,24 +82,24 @@ cgiMain' cache path = "download" -> outputBinary =<< liftIO (BS.readFile path) 'c':'-':_ -> #ifdef C_RUNTIME - cpgfMain command =<< liftIO (readCache (snd cache) path) + cpgfMain command =<< liftIO (readCache' (snd cache) path) #else serverError "Server configured without C run-time support" "" #endif - _ -> pgfMain command =<< liftIO (readCache (fst cache) path) + _ -> pgfMain command =<< liftIO (readCache' (fst cache) path) -------------------------------------------------------------------------------- -- * C run-time functionality #ifdef C_RUNTIME -cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult -cpgfMain command (pgf,pc) = +--cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult +cpgfMain command (t,(pgf,pc)) = case command of - "c-parse" -> out =<< join (parse # input % from % start % limit % trie) - "c-linearize" -> out =<< lin # tree % to - "c-translate" -> out =<< join (trans#input%from%to%start%limit%trie) - "c-flush" -> out =<< flush - "c-grammar" -> out grammar + "c-parse" -> out t=<< join (parse # input % start % limit % trie) + "c-linearize" -> out t=<< lin # tree % to + "c-translate" -> out t=<< join (trans # input % to % start % limit % trie) + "c-flush" -> out t=<< flush + "c-grammar" -> out t grammar _ -> badRequest "Unknown command" command where flush = liftIO $ do modifyMVar_ pc $ const $ return Map.empty @@ -111,9 +113,8 @@ cpgfMain command (pgf,pc) = where languages = [makeObj ["name".= l] | (l,_)<-Map.toList (C.languages pgf)] - parse input (from,concr) start mlimit trie = - do lex <- c_lexer concr - r <- parse' (from,concr) start mlimit (lex input) + parse input@((from,_),_) start mlimit trie = + do r <- parse' start mlimit input return $ showJSON [makeObj ("from".=from:jsonParseResult r)] jsonParseResult = either bad good @@ -122,7 +123,7 @@ cpgfMain command (pgf,pc) = good trees = "trees".=map tp trees :[] -- :addTrie trie trees tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob] - parse' (from,concr) start mlimit input = + parse' start mlimit ((from,concr),input) = liftIO $ do t <- getCurrentTime fmap (maybe id take mlimit . drop start) # modifyMVar pc (parse'' t) @@ -137,12 +138,12 @@ cpgfMain command (pgf,pc) = purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing -- remove unused parse results after 2 minutes - lin tree tos = showJSON (lin' tree tos) - lin' tree tos = [makeObj ["to".=to,"text".=C.linearize c tree]|(to,c)<-tos] + lin tree to = showJSON (lin' tree to) + lin' tree (tos,unlex) = + [makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos] - trans input (from,concr) tos start mlimit trie = - do lex <- c_lexer concr - parses <- parse' (from,concr) start mlimit (lex input) + trans input@((from,_),_) to start mlimit trie = + do parses <- parse' start mlimit input return $ showJSON [ makeObj ["from".=from, "translations".= jsonParses parses]] @@ -152,12 +153,18 @@ cpgfMain command (pgf,pc) = bad err = [makeObj ["error".=err]] good parses = [makeObj ["tree".=tree, "prob".=prob, - "linearizations".=lin' tree tos] + "linearizations".=lin' tree to] | (tree,prob) <- parses] - from = maybe (missing "from") return =<< getLang "from" - - to = getLangs "to" + input = lexit # from % textInput + where + lexit (from,lex) input = (from,lex input) + + from = maybe (missing "from") getlexer =<< getLang "from" + where + getlexer f@(_,concr) = (,) f # c_lexer concr + + to = (,) # getLangs "to" % unlexer getLangs = getLangs' readLang getLang = getLang' readLang @@ -210,45 +217,59 @@ lexer' uncap = maybe (return id) lexerfun =<< getInput "lexer" "mixed" -> return (unwords . lexMixed) _ -> badRequest "Unknown lexer" name + +type Unlexer = String->String + +unlexer :: CGI Unlexer +unlexer = maybe (return id) unlexerfun =<< getInput "unlexer" + where + unlexerfun name = + case name of + "text" -> return (unlexText' . words) + "code" -> return (unlexCode . words) + "mixed" -> return (unlexMixed . words) + _ -> badRequest "Unknown lexer" name + + unlexText' ("+":ws) = "+ "++unlexText ws + unlexText' ("*":ws) = "* "++unlexText ws + unlexText' ws = unlexText ws + -------------------------------------------------------------------------------- -- * Haskell run-time functionality -pgfMain :: String -> PGF -> CGI CGIResult -pgfMain command pgf = +--pgfMain :: String -> PGF -> CGI CGIResult +pgfMain command (t,pgf) = case command of - "parse" -> out =<< join (parse#input%cat%from%limit%trie) - "complete" -> out =<< doComplete pgf # input % cat % from % limit - "linearize" -> out =<< doLinearize pgf # tree % to - "linearizeAll" -> out =<< doLinearizes pgf # tree % to - "linearizeTable" -> out =<< doLinearizeTabular pgf # tree % to - "random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= out - "generate" -> out =<< doGenerate pgf # cat % depth % limit % to - "translate" -> out =<< join (trans#input%cat%from%to%limit%trie) - "translategroup" -> out =<< join (transgroup#input%cat%from%to%limit) - "grammar" -> out =<< doGrammar pgf # requestAcceptLanguage + "parse" -> o =<< doParse pgf # input % cat % limit % trie + "complete" -> o =<< doComplete pgf # input % cat % limit + "linearize" -> o =<< doLinearize pgf # tree % to + "linearizeAll" -> o =<< doLinearizes pgf # tree % to + "linearizeTable" -> o =<< doLinearizeTabular pgf # tree % to + "random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= o + "generate" -> o =<< doGenerate pgf # cat % depth % limit % to + "translate" -> o =<< doTranslate pgf # input % cat % to % limit %trie + "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit + "grammar" -> o =<< doGrammar pgf # requestAcceptLanguage "abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree "alignment" -> outputGraphviz =<< alignment pgf # tree % to "parsetree" -> do t <- tree Just l <- from opts <- graphvizOptions outputGraphviz (parseTree pgf l opts t) - "abstrjson" -> out . jsonExpr =<< tree + "abstrjson" -> o . jsonExpr =<< tree "browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames "external" -> do cmd <- getInput "external" - doExternal cmd =<< input + doExternal cmd =<< textInput _ -> badRequest "Unknown command" command where - parse input cat from limit trie = - do lex <- mlexer from - return (doParse pgf (lex input) cat from limit trie) - trans input cat from to limit trie = - do lex <- mlexer from - return (doTranslate pgf (lex input) cat from to limit trie) - transgroup input cat from to limit = - do lex <- mlexer from - return (doTranslateGroup pgf (lex input) cat from to limit) + o x = out t x --- mlexer _ = lexer + input = do fr <- from + lex <- mlexer fr + inp <- textInput + return (fr,lex inp) + + mlexer Nothing = lexer mlexer (Just lang) = ilexer (PGF.isInMorpho morpho) where morpho = PGF.buildMorpho pgf lang @@ -302,7 +323,7 @@ pgfMain command pgf = bool name = maybe False toBool # getInput name from = getLang "from" - to = getLangs "to" + to = (,) # getLangs "to" % unlexer getLangs = getLangs' readLang getLang = getLang' readLang @@ -316,15 +337,17 @@ pgfMain command pgf = -- * Request parameter access and related auxiliary functions -out = outputJSONP +--out = outputJSONP +out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t + setHeader "Last-Modified" fmt + outputJSONP r getInput1 x = nonEmpty # getInput x nonEmpty (Just "") = Nothing nonEmpty r = r - -input :: CGI String -input = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" +textInput :: CGI String +textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i @@ -380,8 +403,10 @@ doExternal (Just cmd) input = liftIO $ removeFile tmpfile2 return r -doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> Bool -> JSValue -doTranslate pgf input mcat mfrom tos mlimit trie = +type To = ([PGF.Language],Unlexer) + +doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> Bool -> JSValue +doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit trie = showJSON [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po) | (from,po,bs) <- parse' pgf input mcat mfrom] @@ -393,7 +418,8 @@ doTranslate pgf input mcat mfrom tos mlimit trie = ["translations".= [makeObj ["tree".=tree, "linearizations".= - [makeObj ["to".=to, "text".=text, "brackets".=bs] + [makeObj ["to".=to, "text".=unlex text, + "brackets".=bs] | (to,text,bs)<- linearizeAndBind pgf tos tree]] | tree <- maybe id take mlimit trees]] PGF.ParseIncomplete -> ["incomplete".=True] @@ -405,13 +431,13 @@ jsonTypeErrors errs = | (fid,err) <- errs]] -- used in phrasebook -doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue -doTranslateGroup pgf input mcat mfrom tos mlimit = +doTranslateGroup :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> JSValue +doTranslateGroup pgf (mfrom,input) mcat (tos,unlex) mlimit = showJSON [makeObj ["from".=langOnly (PGF.showLanguage from), "to".=langOnly (PGF.showLanguage to), "linearizations".= - [toJSObject (("text", doText alt) : disamb lg from ts) + [toJSObject (("text",unlex alt) : disamb lg from ts) | (ts,alt) <- output, let lg = length output] ] | @@ -430,16 +456,12 @@ doTranslateGroup pgf input mcat mfrom tos mlimit = else (ts,y) : insertAlt t x xs2 _ -> [([t],x)] - doText s = case s of - c:cs | elem (last s) ".?!" -> toUpper c : init (init cs) ++ [last s] - _ -> s - langOnly = reverse . take 3 . reverse disamb lg from ts = if lg < 2 then [] - else [("tree", "-- " ++ groupDisambs [doText (disambLang from t) | t <- ts])] + else [("tree", "-- " ++ groupDisambs [unlex (disambLang from t) | t <- ts])] groupDisambs = unwords . intersperse "/" @@ -457,8 +479,10 @@ doTranslateGroup pgf input mcat mfrom tos mlimit = notDisamb = (/="Disamb") . take 6 . PGF.showLanguage -doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> Bool -> JSValue -doParse pgf input mcat mfrom mlimit trie = showJSON $ map makeObj +type From = (Maybe PGF.Language,String) + +doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue +doParse pgf (mfrom,input) mcat mlimit trie = showJSON $ map makeObj ["from".=from : "brackets".=bs : jsonParseOutput po | (from,po,bs) <- parse' pgf input mcat mfrom] where @@ -473,22 +497,22 @@ doParse pgf input mcat mfrom mlimit trie = showJSON $ map makeObj addTrie trie trees = ["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie] -doComplete :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue -doComplete pgf input mcat mfrom mlimit = showJSON +doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> JSValue +doComplete pgf (mfrom,input) mcat mlimit = showJSON [makeObj ["from".=from, "brackets".=bs, "completions".=cs, "text".=s] | from <- froms, let (bs,s,cs) = complete' pgf from cat mlimit input] where froms = maybe (PGF.languages pgf) (:[]) mfrom cat = fromMaybe (PGF.startCat pgf) mcat -doLinearize :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue -doLinearize pgf tree tos = showJSON - [makeObj ["to".=to, "text".=text,"brackets".=bs] +doLinearize :: PGF -> PGF.Tree -> To -> JSValue +doLinearize pgf tree (tos,unlex) = showJSON + [makeObj ["to".=to, "text".=unlex text,"brackets".=bs] | (to,text,bs) <- linearizeAndBind pgf tos tree] -doLinearizes :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue -doLinearizes pgf tree tos = showJSON - [makeObj ["to".=to, "texts".=map doBind texts] +doLinearizes :: PGF -> PGF.Tree -> To -> JSValue +doLinearizes pgf tree (tos,unlex) = showJSON + [makeObj ["to".=to, "texts".=map (unlex . doBind) texts] | (to,texts) <- linearizes' pgf tos tree] where linearizes' pgf tos tree = @@ -497,29 +521,30 @@ doLinearizes pgf tree tos = showJSON langs = if null tos then PGF.languages pgf else tos lins to = nub . concatMap (map snd) . PGF.tabularLinearizes pgf to -doLinearizeTabular :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue -doLinearizeTabular pgf tree tos = showJSON +doLinearizeTabular :: PGF -> PGF.Tree -> To -> JSValue +doLinearizeTabular pgf tree (tos,unlex) = showJSON [makeObj ["to".=to, - "table".=[makeObj ["params".=ps,"texts".=ts] | (ps,ts)<-texts]] + "table".=[makeObj ["params".=ps,"texts".=map unlex ts] + | (ps,ts)<-texts]] | (to,texts) <- linearizeTabular pgf tos tree] -doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> IO JSValue -doRandom pgf mcat mdepth mlimit tos = +doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> IO JSValue +doRandom pgf mcat mdepth mlimit to = do g <- newStdGen let trees = PGF.generateRandomDepth g pgf cat (Just depth) return $ showJSON [makeObj ["tree".=PGF.showExpr [] tree, - "linearizations".= doLinearizes pgf tree tos] + "linearizations".= doLinearizes pgf tree to] | tree <- limit trees] where cat = fromMaybe (PGF.startCat pgf) mcat limit = take (fromMaybe 1 mlimit) depth = fromMaybe 4 mdepth -doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> JSValue -doGenerate pgf mcat mdepth mlimit tos = +doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> JSValue +doGenerate pgf mcat mdepth mlimit (tos,unlex) = showJSON [makeObj ["tree".=PGF.showExpr [] tree, "linearizations".= - [makeObj ["to".=to, "text".=text] + [makeObj ["to".=to, "text".=unlex text] | (to,text,bs) <- linearizeAndBind pgf tos tree]] | tree <- limit trees] where @@ -567,7 +592,7 @@ abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree parseTree pgf lang opts tree = PGF.graphvizParseTree pgf lang opts tree -alignment pgf tree tos = PGF.graphvizAlignment pgf tos' tree +alignment pgf tree (tos,unlex) = PGF.graphvizAlignment pgf tos' tree where tos' = if null tos then PGF.languages pgf else tos pipeIt2graphviz :: String -> String -> IO BS.ByteString @@ -791,16 +816,11 @@ linearizeTabular pgf tos tree = linearizeAndBind pgf mto tree = [(to,s,bss) | to<-langs, let bss = PGF.bracketedLinearize pgf to (transfer to tree) - s = unwords . bind $ concatMap PGF.flattenBracketedString bss] + s = unwords . bindTok $ concatMap PGF.flattenBracketedString bss] where langs = if null mto then PGF.languages pgf else mto -doBind = unwords . bind . words -bind ws = case ws of - w : "&+" : u : ws2 -> bind ((w ++ u) : ws2) - "&+":ws2 -> bind ws2 - w : ws2 -> w : bind ws2 - _ -> ws +doBind = unwords . bindTok . words selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language selectLanguage pgf macc = case acceptable of