GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-05 17:22:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

GF cloud: more readable formatting of the GF version page

Browse Source 
Factor out common CSS from gfse/editor.css into clouds.css.
This commit is contained in:
hallgren
2016-06-15 10:20:30 +00:00
parent 1465a825d5
commit 12d2296991
4 changed files with 47 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/compiler/GF/Server.hs
View File

@@ -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 = root</>rpath -- hmm, check for ".."
versionInfo (c1,c2) =
html200 . unlines $
"<!DOCTYPE html>":
"<meta name = \"viewport\" content = \"width = device-width\">":
"<link rel=\"stylesheet\" type=\"text/css\" href=\"cloud.css\" title=\"Cloud\">":
"":
("<h2>"++hdr++"</h2>"):
(zipWith (++) ("<p>":repeat "<br>") 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) = "<tr><td>"++rel path++"<td>"++show t
sh _ [] = []
sh hdr gs =
"":("<h3>"++hdr++"</h3>"):
"<table class=loaded_grammars><tr><th>Grammar<th>Last modified":
map sh1 gs++
["</table>"]
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"