GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 19:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

gf -server: fix for directory URLs without a trailing slash

Browse Source 
When a browser requests a URL that refers to a directory, web server usually
redirect the browser to the same URL with a trailing '/' added, if one was not
already present. This is to prevent relative links in the returned document
from being interpreted relative to the parent directory instead of the current
document. This type of redirection was missing in gf -server.
This commit is contained in:
hallgren
2013-08-20 15:38:26 +00:00
parent cbe2cb9908
commit 08766585e6
1 changed files with 11 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
src/compiler/GFServer.hs
View File

@@ -314,9 +314,13 @@ jsonresult cwd dir cmd (ecode,stdout,stderr) files =
-- * Static content -- * Static content
serveStaticFile path = serveStaticFile path =
do b <- doesDirectoryExist path do --logPutStrLn $ "Serving static file "++path
let path' = if b then path </> "index.html" else path b <- doesDirectoryExist path
serveStaticFile' path' if b
then if path `elem` ["","."] || last path=='/'
then serveStaticFile' (path </> "index.html")
else return (resp301 (path++"/"))
else serveStaticFile' path
serveStaticFile' path = serveStaticFile' path =
do let ext = takeExtension path do let ext = takeExtension path
@@ -346,6 +350,8 @@ json200' f = ok200' jsonUTF8 . encodeString . f . encode
jsonp200' f = ok200' jsonpUTF8 . encodeString . f . encode jsonp200' f = ok200' jsonpUTF8 . encodeString . f . encode
html200 = ok200' htmlUTF8 . encodeString html200 = ok200' htmlUTF8 . encodeString
resp204 = Response 204 [xo] "" -- no content resp204 = Response 204 [xo] "" -- no content
resp301 url = Response 301 [plain,xo,location url] $
"Moved permanently to "++url
resp400 msg = Response 400 [plain,xo] $ "Bad request: "++msg++"\n" resp400 msg = Response 400 [plain,xo] $ "Bad request: "++msg++"\n"
resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n" resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n"
resp500 msg = Response 500 [plain,xo] $ "Internal error: "++msg++"\n" resp500 msg = Response 500 [plain,xo] $ "Internal error: "++msg++"\n"
@@ -366,6 +372,7 @@ ct t cs = ("Content-Type",t++cs)
csutf8 = "; charset=UTF-8" csutf8 = "; charset=UTF-8"
xo = ("Access-Control-Allow-Origin","*") -- Allow cross origin requests xo = ("Access-Control-Allow-Origin","*") -- Allow cross origin requests
-- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS
location url = ("Location",url)
contentTypeFromExt ext = contentTypeFromExt ext =
case ext of case ext of
@@ -426,7 +433,7 @@ removeDir dir =
removeDirectory dir removeDirectory dir
setDir path = setDir path =
do logPutStrLn $ "cd "++show path do --logPutStrLn $ "cd "++show path
setCurrentDirectory path setCurrentDirectory path
{- {-