From 12d2296991aad74ec0ae5f837aa27119ca062196 Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 15 Jun 2016 10:20:30 +0000 Subject: GF cloud: more readable formatting of the GF version page Factor out common CSS from gfse/editor.css into clouds.css. --- src/compiler/GF/Server.hs | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) (limited to 'src/compiler') diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index d5c84b87c..de0ec6abc 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -161,11 +161,7 @@ handle logLn documentroot state0 cache execute1 stateVar -- "/stop" -> -- "/start" -> "/parse" -> parse (decoded qs) - "/version" -> do (c1,c2) <- PS.listPGFCache cache - let rel = makeRelative documentroot - sh1 (path,t) = rel path++" "++show t - sh = map sh1 - return $ ok200 (unlines (gf_version:"":sh c1++"":sh c2)) + "/version" -> versionInfo `fmap` PS.listPGFCache cache "/flush" -> do PS.flushPGFCache cache; return (ok200 "flushed") '/':rpath -> -- This code runs without mutual exclusion, so it must *not* @@ -183,6 +179,27 @@ handle logLn documentroot state0 cache execute1 stateVar translatePath rpath = rootrpath -- hmm, check for ".." + versionInfo (c1,c2) = + html200 . unlines $ + "": + "": + "": + "": + ("

"++hdr++"

"): + (zipWith (++) ("

":repeat "
") buildinfo)++ + sh "Haskell run-time system" c1++ + sh "C run-time system" c2 + where + hdr:buildinfo = lines gf_version + rel = makeRelative documentroot + sh1 (path,t) = ""++rel path++""++show t + sh _ [] = [] + sh hdr gs = + "":("

"++hdr++"

"): + "
GrammarLast modified": + map sh1 gs++ + ["
"] + wrapCGI cgi = cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq look field = @@ -371,7 +388,7 @@ ok200' t = Response 200 [t,xo] json200 x = json200' id x json200' f = ok200' jsonUTF8 . encodeString . f . encode jsonp200' f = ok200' jsonpUTF8 . encodeString . f . encode ---html200 = ok200' htmlUTF8 . encodeString +html200 = ok200' htmlUTF8 . encodeString resp204 = Response 204 [xo] "" -- no content resp301 url = Response 301 [plain,xo,location url] $ "Moved permanently to "++url @@ -389,7 +406,7 @@ plain = ct "text/plain" "" plainUTF8 = ct "text/plain" csutf8 jsonUTF8 = ct "application/json" csutf8 -- http://www.ietf.org/rfc/rfc4627.txt jsonpUTF8 = ct "application/javascript" csutf8 ---htmlUTF8 = ct "text/html" csutf8 +htmlUTF8 = ct "text/html" csutf8 ct t cs = ("Content-Type",t++cs) csutf8 = "; charset=UTF-8" -- cgit v1.2.3