diff options
| author | hallgren <hallgren@chalmers.se> | 2013-08-20 15:38:26 +0000 |
|---|---|---|
| committer | hallgren <hallgren@chalmers.se> | 2013-08-20 15:38:26 +0000 |
| commit | 08766585e6da5645a94f8cf798dc23ebe1ac6a64 (patch) | |
| tree | 721b4c3827819ef423fbf7d3bacebbaa40644e43 /src | |
| parent | cbe2cb99081d86a6aa37e375eb41a2e0a2d16f35 (diff) | |
gf -server: fix for directory URLs without a trailing slash
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.
Diffstat (limited to 'src')
| -rw-r--r-- | src/compiler/GFServer.hs | 15 |
1 files changed, 11 insertions, 4 deletions
diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index 2ba645268..5b247806a 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -314,9 +314,13 @@ jsonresult cwd dir cmd (ecode,stdout,stderr) files = -- * Static content serveStaticFile path = - do b <- doesDirectoryExist path - let path' = if b then path </> "index.html" else path - serveStaticFile' path' + do --logPutStrLn $ "Serving static file "++path + b <- doesDirectoryExist path + if b + then if path `elem` ["","."] || last path=='/' + then serveStaticFile' (path </> "index.html") + else return (resp301 (path++"/")) + else serveStaticFile' path serveStaticFile' path = do let ext = takeExtension path @@ -346,6 +350,8 @@ json200' f = ok200' jsonUTF8 . encodeString . f . encode jsonp200' f = ok200' jsonpUTF8 . encodeString . f . encode html200 = ok200' htmlUTF8 . encodeString 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" resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\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" xo = ("Access-Control-Allow-Origin","*") -- Allow cross origin requests -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS +location url = ("Location",url) contentTypeFromExt ext = case ext of @@ -426,7 +433,7 @@ removeDir dir = removeDirectory dir setDir path = - do logPutStrLn $ "cd "++show path + do --logPutStrLn $ "cd "++show path setCurrentDirectory path {- |