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

gf -server: defend against problems with the current directory caused unhandled errors

Browse Source
This commit is contained in:
hallgren
2013-01-12 17:11:31 +00:00
parent 488624255a
commit cfb72bad8b
1 changed files with 5 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/compiler/GFServer.hs
View File

@@ -68,7 +68,7 @@ server port optroot execute1 state0 =
putStrLn $ "Document root = "++root putStrLn $ "Document root = "++root
putStrLn $ "Starting HTTP server, open http://localhost:" putStrLn $ "Starting HTTP server, open http://localhost:"
++show port++"/ in your web browser." ++show port++"/ in your web browser."
initServer port (modifyMVar state . handle state0 cache execute1) initServer port (modifyMVar state . handle root state0 cache execute1)
gf_version = "This is GF version "++showVersion version++".\n"++buildInfo gf_version = "This is GF version "++showVersion version++".\n"++buildInfo
@@ -126,7 +126,7 @@ hmtry m = do s <- get
Right (Right (a,s)) -> do put s;return (Right a) Right (Right (a,s)) -> do put s;return (Right a)
-- | HTTP request handler -- | HTTP request handler
handle state0 cache execute1 handle root state0 cache execute1
rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) state = rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) state =
case method of case method of
"POST" -> run normal_request (utf8inputs body,state) "POST" -> run normal_request (utf8inputs body,state)
@@ -134,7 +134,9 @@ handle state0 cache execute1
_ -> return (state,resp501 $ "method "++method) _ -> return (state,resp501 $ "method "++method)
where where
normal_request = normal_request =
do qs <- get_qs do -- Defend against unhandled errors under inDir:
liftIO $ setCurrentDirectory root
qs <- get_qs
logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs) logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
case upath of case upath of
"/new" -> new "/new" -> new