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