msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

GFServer.hs: code improvements

Browse Source 
Use a monad in the request handler to make the code a bit more modular and
readable.
This commit is contained in:
hallgren
2012-09-22 22:10:10 +00:00
parent a9476634a4
commit 2f500e521d
1 changed files with 119 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files

201
src/compiler/GFServer.hs
View File

@@ -5,6 +5,8 @@ import Data.List(partition,stripPrefix,tails,isInfixOf)
import Data.Maybe(mapMaybe) import Data.Maybe(mapMaybe)
import qualified Data.Map as M import qualified Data.Map as M
import Control.Monad(when) import Control.Monad(when)
import Control.Monad.State(StateT(..),get,gets,put)
import Control.Monad.Error(ErrorT(..),Error(..))
import System.Random(randomRIO) import System.Random(randomRIO)
import System.IO(stdout,stderr,hPutStrLn) import System.IO(stdout,stderr,hPutStrLn)
import System.IO.Error(try,ioError,isAlreadyExistsError) import System.IO.Error(try,ioError,isAlreadyExistsError)
@@ -41,7 +43,7 @@ import RunHTTP(cgiHandler)
--logFile :: FilePath --logFile :: FilePath
--logFile = "pgf-error.log" --logFile = "pgf-error.log"
debug s = liftIO (logPutStrLn s) debug s = logPutStrLn s
-- | Combined FastCGI and HTTP server -- | Combined FastCGI and HTTP server
server port execute1 state0 = server port execute1 state0 =
@@ -91,127 +93,151 @@ handle_fcgi execute1 state0 stateM cache =
debug $ "done "++show n debug $ "done "++show n
-} -}
-- * Request handler
-- | Handler monad
type HM s a = StateT (Q,s) (ErrorT Response IO) a
run :: HM s Response -> (Q,s) -> IO (s,Response)
run m s = either bad ok =<< runErrorT (runStateT m s)
where
bad resp = return (snd s,resp)
ok (resp,(qs,state)) = return (state,resp)
get_qs :: HM s Q
get_qs = gets fst
get_state :: HM s s
get_state = gets snd
put_qs qs = do state <- get_state; put (qs,state)
put_state state = do qs <- get_qs; put (qs,state)
err :: Response -> HM s a
err e = StateT $ \ s -> ErrorT $ return $ Left e
hmtry :: HM s a -> HM s (Either (Either IOError Response) a)
hmtry m = do s <- get
e <- liftIO $ try $ runErrorT $ runStateT m s
case e of
Left ioerror -> return (Left (Left ioerror))
Right (Left resp) -> return (Left (Right resp))
Right (Right (a,s)) -> do put s;return (Right a)
-- | HTTP request handler -- | HTTP request handler
handle state0 cache execute1 handle 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" -> normal_request (utf8inputs body) "POST" -> run normal_request (utf8inputs body,state)
"GET" -> normal_request (utf8inputs q) "GET" -> run normal_request (utf8inputs q,state)
_ -> return (state,resp501 $ "method "++method) _ -> return (state,resp501 $ "method "++method)
where where
normal_request qs = normal_request =
do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs) do qs <- get_qs
logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
case upath of case upath of
"/new" -> new "/new" -> new
-- "/stop" -> -- "/stop" ->
-- "/start" -> -- "/start" ->
"/gfshell" -> inDir qs $ look "command" . command "/gfshell" -> inDir command
"/parse" -> parse (decoded qs) "/parse" -> parse (decoded qs)
"/cloud" -> inDir qs $ look "command" . cloud "/cloud" -> inDir cloud
'/':rpath -> '/':rpath ->
case (takeDirectory path,takeFileName path,takeExtension path) of case (takeDirectory path,takeFileName path,takeExtension path) of
(_ ,_ ,".pgf") -> wrapCGI $ PS.cgiMain' cache path (_ ,_ ,".pgf") -> wrapCGI $ PS.cgiMain' cache path
(dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs) (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs)
(dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir cache (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir cache
_ -> do resp <- serveStaticFile path _ -> liftIO $ serveStaticFile path
return (state,resp)
where path = translatePath rpath where path = translatePath rpath
_ -> return (state,resp400 upath) _ -> err $ resp400 upath
root = "." root = "."
translatePath rpath = root</>rpath -- hmm, check for ".." translatePath rpath = root</>rpath -- hmm, check for ".."
wrapCGI cgi = wrapCGI cgi =
do resp <- cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq liftIO $ cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq
return (state,resp)
look field ok qs = look field =
case partition ((==field).fst) qs of do qs <- get_qs
((_,(value,_)):qs1,qs2) -> ok value (qs1++qs2) case partition ((==field).fst) qs of
_ -> bad ((_,(value,_)):qs1,qs2) -> do put_qs (qs1++qs2)
where return value
bad = return (state,resp400 $ "no "++field++" in request") _ -> err $ resp400 $ "no "++field++" in request"
inDir qs ok = look "dir" cd qs inDir ok = cd =<< look "dir"
where where
cd ('/':dir@('t':'m':'p':_)) qs' = cd ('/':dir@('t':'m':'p':_)) =
do cwd <- getCurrentDirectory do cwd <- liftIO $ getCurrentDirectory
b <- try $ setCurrentDirectory dir b <- liftIO $ try $ setCurrentDirectory dir
case b of case b of
Left _ -> do b <- try $ readFile dir -- poor man's symbolic links Left _ -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links
case b of case b of
Left _ -> return (state,resp404 dir) Left _ -> err $ resp404 dir
Right dir' -> cd dir' qs' Right dir' -> cd dir'
Right _ -> do logPutStrLn $ "cd "++dir Right _ -> do logPutStrLn $ "cd "++dir
r <- try (ok dir qs') r <- hmtry (ok dir)
setCurrentDirectory cwd liftIO $ setCurrentDirectory cwd
either ioError return r either (either (liftIO . ioError) err) return r
cd dir _ = return (state,resp400 $ "unacceptable directory "++dir) cd dir = err $ resp400 $ "unacceptable directory "++dir
new = new = fmap ok200 $ liftIO $ newDirectory
do dir <- newDirectory
return (state,ok200 dir)
command dir cmd _ = command dir =
do let st = maybe state0 id $ M.lookup dir state do cmd <- look "command"
(output,st') <- hCapture [stdout,stderr] (execute1 st cmd) state <- get_state
let st = maybe state0 id $ M.lookup dir state
(output,st') <- liftIO $ hCapture [stdout,stderr] (execute1 st cmd)
let state' = maybe state (flip (M.insert dir) state) st' let state' = maybe state (flip (M.insert dir) state) st'
return (state',ok200 output) put_state state'
return $ ok200 output
parse qs = parse qs = return $ json200 (makeObj(map parseModule qs))
return (state,json200 (makeObj(map parseModule qs)))
cloud dir cmd qs = cloud dir =
case cmd of do cmd <- look "command"
"make" -> make dir (raw qs) case cmd of
"upload" -> upload (raw qs) "make" -> make dir . raw =<< get_qs
"ls" -> jsonList (maybe ".json" fst $ lookup "ext" qs) "upload" -> upload . raw =<< get_qs
"rm" -> with_file qs rm "ls" -> jsonList . maybe ".json" fst . lookup "ext" =<< get_qs
"download" -> with_file qs download "rm" -> rm =<< look_file
"link_directories" -> look "newdir" (link_directories dir) qs "download" -> download =<< look_file
_ -> return (state,resp400 $ "cloud command "++cmd) "link_directories" -> link_directories dir =<< look "newdir"
_ -> err $ resp400 $ "cloud command "++cmd
with_file qs f = look "file" check qs look_file = check =<< look "file"
where where
check path qs = check path =
if ok_access path if ok_access path
then f path qs then return path
else return (state,resp400 $ "unacceptable path "++path) else err $ resp400 $ "unacceptable path "++path
make dir files = make dir files =
do (state,_) <- upload files do _ <- upload files
let args = "-s":"-make":map fst files let args = "-s":"-make":map fst files
cmd = unwords ("gf":args) cmd = unwords ("gf":args)
out <- readProcessWithExitCode "gf" args "" out <- liftIO $ readProcessWithExitCode "gf" args ""
cwd <- getCurrentDirectory cwd <- liftIO $ getCurrentDirectory
return (state,json200 (jsonresult cwd ('/':dir++"/") cmd out files)) return $ json200 (jsonresult cwd ('/':dir++"/") cmd out files)
upload files = upload files =
if null badpaths if null badpaths
then do mapM_ (uncurry updateFile) okfiles then do liftIO $ mapM_ (uncurry updateFile) okfiles
return (state,resp204) return resp204
else return (state,resp404 $ "unacceptable path(s) "++unwords badpaths) else err $ resp404 $ "unacceptable path(s) "++unwords badpaths
where where
(okfiles,badpaths) = apSnd (map fst) $ partition (ok_access.fst) files (okfiles,badpaths) = apSnd (map fst) $ partition (ok_access.fst) files
jsonList ext = jsonList ext = fmap (json200) (ls_ext "." ext)
do jsons <- ls_ext "." ext
return (state,json200 jsons)
ok_to_delete = [".json",".gfstdoc",".gfo",".gf",".pgf"] rm path | takeExtension path `elem` ok_to_delete =
do b <- liftIO $ doesFileExist path
rm path _ | takeExtension path `elem` ok_to_delete =
do b <- doesFileExist path
if b if b
then do removeFile path then do liftIO $ removeFile path
return (state,ok200 "") return $ ok200 ""
else return (state,resp404 path) else err $ resp404 path
rm path _ = return (state,resp400 $ "unacceptable extension "++path) rm path = err $ resp400 $ "unacceptable extension "++path
download path _ = (,) state `fmap` serveStaticFile path download path = liftIO $ serveStaticFile path
link_directories olddir newdir@('/':'t':'m':'p':'/':_) _ | old/=new = link_directories olddir newdir@('/':'t':'m':'p':'/':_) | old/=new =
liftIO $
do setCurrentDirectory ".." do setCurrentDirectory ".."
logPutStrLn =<< getCurrentDirectory logPutStrLn =<< getCurrentDirectory
logPutStrLn $ "link_dirs new="++new++", old="++old logPutStrLn $ "link_dirs new="++new++", old="++old
@@ -225,29 +251,29 @@ handle state0 cache execute1
if isLink then removeLink old else removeDir old if isLink then removeLink old else removeDir old
createSymbolicLink new old createSymbolicLink new old
#endif #endif
return (state,ok200 "") return $ ok200 ""
where where
old = takeFileName olddir old = takeFileName olddir
new = takeFileName newdir new = takeFileName newdir
link_directories olddir newdir _ = link_directories olddir newdir =
return (state,resp400 $ "unacceptable directories "++olddir++" "++newdir) err $ resp400 $ "unacceptable directories "++olddir++" "++newdir
grammarList dir qs = grammarList dir qs =
do pgfs <- ls_ext dir ".pgf" do pgfs <- ls_ext dir ".pgf"
return (state,jsonp qs pgfs) return $ jsonp qs pgfs
ls_ext dir ext = ls_ext dir ext =
do paths <- getDirectoryContents dir do paths <- liftIO $ getDirectoryContents dir
return [path | path<-paths, takeExtension path==ext] return [path | path<-paths, takeExtension path==ext]
-- * Dynamic content -- * Dynamic content
jsonresult cwd dir cmd (ecode,stdout,stderr) files = jsonresult cwd dir cmd (ecode,stdout,stderr) files =
makeObj [ makeObj [
prop "errorcode" (if ecode==ExitSuccess then "OK" else "Error"), "errorcode" .= if ecode==ExitSuccess then "OK" else "Error",
prop "command" cmd, "command" .= cmd,
prop "output" (unlines [rel stderr,rel stdout]), "output" .= unlines [rel stderr,rel stdout],
prop "minibar_url" ("/minibar/minibar.html?"++dir++pgf)] "minibar_url" .= "/minibar/minibar.html?"++dir++pgf]
where where
pgf = case files of pgf = case files of
(abstract,_):_ -> "%20"++dropExtension abstract++".pgf" (abstract,_):_ -> "%20"++dropExtension abstract++".pgf"
@@ -324,7 +350,7 @@ serveStaticFile' path =
else return (resp404 path) else return (resp404 path)
-- * Logging -- * Logging
logPutStrLn = hPutStrLn stderr logPutStrLn s = liftIO . hPutStrLn stderr $ s
-- * JSONP output -- * JSONP output
@@ -341,8 +367,13 @@ html200 = ok200' htmlUTF8 . encodeString
resp204 = Response 204 [] "" -- no content resp204 = Response 204 [] "" -- no content
resp400 msg = Response 400 [plain] $ "Bad request: "++msg++"\n" resp400 msg = Response 400 [plain] $ "Bad request: "++msg++"\n"
resp404 path = Response 404 [plain] $ "Not found: "++path++"\n" resp404 path = Response 404 [plain] $ "Not found: "++path++"\n"
resp500 msg = Response 500 [plain] $ "Internal error: "++msg++"\n"
resp501 msg = Response 501 [plain] $ "Not implemented: "++msg++"\n" resp501 msg = Response 501 [plain] $ "Not implemented: "++msg++"\n"
instance Error Response where
noMsg = resp500 "no message"
strMsg = resp500
-- * Content types -- * Content types
plain = ct "text/plain" plain = ct "text/plain"
plainUTF8 = ct "text/plain; charset=UTF-8" plainUTF8 = ct "text/plain; charset=UTF-8"
@@ -381,6 +412,9 @@ ok_access path =
'.':'.':'/':_ -> False '.':'.':'/':_ -> False
_ -> not ("/../" `isInfixOf` path) _ -> not ("/../" `isInfixOf` path)
-- | Only delete files with these extensions
ok_to_delete = [".json",".gfstdoc",".gfo",".gf",".pgf"]
newDirectory = newDirectory =
do debug "newDirectory" do debug "newDirectory"
loop 10 loop 10
@@ -416,6 +450,8 @@ toHeader s = FCGI.HttpExtensionHeader s -- cheating a bit
-- * misc utils -- * misc utils
--utf8inputs = mapBoth decodeString . inputs --utf8inputs = mapBoth decodeString . inputs
type Q = [(String,(String,String))]
utf8inputs :: String -> Q
utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q] utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q]
decoded = mapSnd fst decoded = mapSnd fst
raw = mapSnd snd raw = mapSnd snd
@@ -432,4 +468,5 @@ mapBoth = map . apBoth
apBoth f (x,y) = (f x,f y) apBoth f (x,y) = (f x,f y)
apSnd f (x,y) = (x,f y) apSnd f (x,y) = (x,f y)
prop n v = (n,showJSON v) infix 1 .=
n .= v = (n,showJSON v)