forked from GitHub/gf-core
782bdf3a52
(1) introduces the module GF.Infra.Concurreny with lifted concurrency
operators (to reduce uses of liftIO) and some additional concurrency
utilities, e.g. a function for sequential logging that is used in
both GF.CompileInParallel and GFServer.
(2) avoids leaving broken .gfo files behind if compilation is aborted.
495 lines
17 KiB
Haskell
495 lines
17 KiB
Haskell
-- | GF server mode
|
|
{-# LANGUAGE CPP #-}
|
|
module GFServer(server) where
|
|
import Data.List(partition,stripPrefix,isInfixOf)
|
|
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(stderr,hPutStrLn)
|
|
import GF.System.Catch(try)
|
|
import Control.Exception(bracket_)
|
|
import System.IO.Error(isAlreadyExistsError)
|
|
import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
|
|
setCurrentDirectory,getCurrentDirectory,
|
|
getDirectoryContents,removeFile,removeDirectory,
|
|
getModificationTime)
|
|
import Data.Time (getCurrentTime,formatTime)
|
|
import System.Locale(defaultTimeLocale,rfc822DateFormat)
|
|
import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory,
|
|
(</>),makeRelative)
|
|
#ifndef mingw32_HOST_OS
|
|
import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink,
|
|
createSymbolicLink)
|
|
#endif
|
|
import GF.Infra.Concurrency(newMVar,modifyMVar,newLog)
|
|
import Network.URI(URI(..))
|
|
import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
|
|
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
|
|
import Network.CGI(handleErrors,liftIO)
|
|
import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
|
|
import Text.JSON(encode,showJSON,makeObj)
|
|
--import System.IO.Silently(hCapture)
|
|
import System.Process(readProcessWithExitCode)
|
|
import System.Exit(ExitCode(..))
|
|
import Codec.Binary.UTF8.String(decodeString,encodeString)
|
|
import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
|
|
import GF.Infra.SIO(captureSIO)
|
|
import qualified PGFService as PS
|
|
import qualified ExampleService as ES
|
|
import Data.Version(showVersion)
|
|
import Paths_gf(getDataDir,version)
|
|
import GF.Infra.BuildInfo (buildInfo)
|
|
import SimpleEditor.Convert(parseModule)
|
|
import RunHTTP(cgiHandler)
|
|
import URLEncoding(decodeQuery)
|
|
|
|
--logFile :: FilePath
|
|
--logFile = "pgf-error.log"
|
|
|
|
debug s = logPutStrLn s
|
|
|
|
-- | Combined FastCGI and HTTP server
|
|
server port optroot execute1 state0 =
|
|
do --stderrToFile logFile
|
|
state <- newMVar M.empty
|
|
cache <- PS.newPGFCache
|
|
datadir <- getDataDir
|
|
let root = maybe (datadir</>"www") id optroot
|
|
-- debug $ "document root="++root
|
|
setDir root
|
|
-- FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache)
|
|
-- if acceptLoop returns, then GF was not invoked as a FastCGI script
|
|
http_server execute1 state0 state cache root
|
|
where
|
|
-- | HTTP server
|
|
http_server execute1 state0 state cache root =
|
|
do logLn <- newLog ePutStrLn -- to avoid intertwined log messages
|
|
logLn gf_version
|
|
logLn $ "Document root = "++root
|
|
logLn $ "Starting HTTP server, open http://localhost:"
|
|
++show port++"/ in your web browser."
|
|
initServer port (handle logLn root state0 cache execute1 state)
|
|
|
|
gf_version = "This is GF version "++showVersion version++".\n"++buildInfo
|
|
|
|
{-
|
|
-- | FastCGI request handler
|
|
handle_fcgi execute1 state0 stateM cache =
|
|
do Just method <- FCGI.getRequestMethod
|
|
debug $ "request method="++method
|
|
Just path <- FCGI.getPathInfo
|
|
-- debug $ "path info="++path
|
|
query <- maybe (return "") return =<< FCGI.getQueryString
|
|
-- debug $ "query string="++query
|
|
let uri = URI "" Nothing path query ""
|
|
headers <- fmap (mapFst show) FCGI.getAllRequestHeaders
|
|
body <- fmap BS.unpack FCGI.fGetContents
|
|
let req = Request method uri headers body
|
|
-- debug (show req)
|
|
(output,resp) <- liftIO $ hCapture [stdout] $ modifyMVar stateM $ handle state0 cache execute1 req
|
|
let Response code headers body = resp
|
|
-- debug output
|
|
debug $ " "++show code++" "++show headers
|
|
FCGI.setResponseStatus code
|
|
mapM_ (uncurry (FCGI.setResponseHeader . toHeader)) headers
|
|
let pbody = BS.pack body
|
|
n = BS.length pbody
|
|
FCGI.fPut pbody
|
|
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
|
|
|
|
hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
|
|
hmbracket_ pre post m =
|
|
do s <- get
|
|
e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s
|
|
case e of
|
|
Left resp -> err resp
|
|
Right (a,s) -> do put s;return a
|
|
|
|
-- | HTTP request handler
|
|
handle logLn documentroot state0 cache execute1 stateVar
|
|
rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) =
|
|
addDate $
|
|
case method of
|
|
"POST" -> normal_request (utf8inputs body)
|
|
"GET" -> normal_request (utf8inputs q)
|
|
_ -> return (resp501 $ "method "++method)
|
|
where
|
|
logPutStrLn msg = liftIO $ logLn msg
|
|
debug msg = logPutStrLn msg
|
|
|
|
addDate m =
|
|
do t <- getCurrentTime
|
|
r <- m
|
|
let fmt = formatTime defaultTimeLocale rfc822DateFormat t
|
|
return r{resHeaders=("Date",fmt):resHeaders r}
|
|
|
|
normal_request qs =
|
|
do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
|
|
let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s)
|
|
-- stateful ensures mutual exclusion, so you can use/change the cwd
|
|
case upath of
|
|
"/new" -> stateful $ new
|
|
"/gfshell" -> stateful $ inDir command
|
|
"/cloud" -> stateful $ inDir cloud
|
|
-- "/stop" ->
|
|
-- "/start" ->
|
|
"/parse" -> parse (decoded qs)
|
|
"/version" -> do (c1,c2) <- PS.listPGFCache cache
|
|
let rel = map (makeRelative documentroot)
|
|
return $ ok200 (unlines (gf_version:"":rel c1++"":rel c2))
|
|
"/flush" -> do PS.flushPGFCache cache; return (ok200 "flushed")
|
|
'/':rpath ->
|
|
-- This code runs without mutual exclusion, so it must *not*
|
|
-- use/change the cwd. Access files by absolute paths only.
|
|
case (takeDirectory path,takeFileName path,takeExtension path) of
|
|
(_ ,_ ,".pgf") -> do --debug $ "PGF service: "++path
|
|
wrapCGI $ PS.cgiMain' cache path
|
|
(dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs)
|
|
(dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (fst cache)
|
|
_ -> serveStaticFile rpath path
|
|
where path = translatePath rpath
|
|
_ -> return $ resp400 upath
|
|
|
|
root = documentroot
|
|
|
|
translatePath rpath = root</>rpath -- hmm, check for ".."
|
|
|
|
wrapCGI cgi = 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 ok = cd =<< look "dir"
|
|
where
|
|
cd ('/':dir@('t':'m':'p':_)) =
|
|
do cwd <- getCurrentDirectory
|
|
b <- doesDirectoryExist dir
|
|
case b of
|
|
False -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links
|
|
case b of
|
|
Left _ -> err $ resp404 dir
|
|
Right dir' -> cd dir'
|
|
True -> do --logPutStrLn $ "cd "++dir
|
|
hmInDir dir (ok dir)
|
|
cd dir = err $ resp400 $ "unacceptable directory "++dir
|
|
|
|
-- First ensure that only one thread that depends on the cwd is running!
|
|
hmInDir dir = hmbracket_ (setDir dir) (setDir documentroot)
|
|
|
|
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 $ captureSIO $ execute1 st cmd
|
|
let state' = maybe state (flip (M.insert dir) state) st'
|
|
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 id dir . raw =<< get_qs
|
|
"remake" -> make skip_empty dir . raw =<< get_qs
|
|
"upload" -> upload id . raw =<< get_qs
|
|
"ls" -> jsonList . maybe ".json" fst . lookup "ext" =<< get_qs
|
|
"ls-l" -> jsonListLong . 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 =
|
|
if ok_access path
|
|
then return path
|
|
else err $ resp400 $ "unacceptable path "++path
|
|
|
|
make skip dir args =
|
|
do let (flags,files) = partition ((=="-").take 1.fst) args
|
|
_ <- upload skip files
|
|
let args = "-s":"-make":map flag flags++map fst files
|
|
flag (n,"") = n
|
|
flag (n,v) = n++"="++v
|
|
cmd = unwords ("gf":args)
|
|
logPutStrLn cmd
|
|
out@(ecode,_,_) <- liftIO $ readProcessWithExitCode "gf" args ""
|
|
logPutStrLn $ show ecode
|
|
cwd <- getCurrentDirectory
|
|
return $ json200 (jsonresult cwd ('/':dir++"/") cmd out files)
|
|
|
|
upload skip files =
|
|
if null badpaths
|
|
then do liftIO $ mapM_ (uncurry updateFile) (skip okfiles)
|
|
return resp204
|
|
else err $ resp404 $ "unacceptable path(s) "++unwords badpaths
|
|
where
|
|
(okfiles,badpaths) = apSnd (map fst) $ partition (ok_access.fst) files
|
|
|
|
skip_empty = filter (not.null.snd)
|
|
|
|
jsonList = jsonList' return
|
|
jsonListLong = jsonList' (mapM addTime)
|
|
jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext)
|
|
|
|
addTime path =
|
|
do t <- getModificationTime path
|
|
return $ makeObj ["path".=path,"time".=format t]
|
|
where
|
|
format = formatTime defaultTimeLocale rfc822DateFormat
|
|
|
|
rm path | takeExtension path `elem` ok_to_delete =
|
|
do b <- doesFileExist path
|
|
if b
|
|
then do removeFile path
|
|
return $ ok200 ""
|
|
else err $ resp404 path
|
|
rm path = err $ resp400 $ "unacceptable extension "++path
|
|
|
|
download path = liftIO $ serveStaticFile' path
|
|
|
|
link_directories olddir newdir@('/':'t':'m':'p':'/':_) | old/=new =
|
|
hmInDir ".." $ liftIO $
|
|
do logPutStrLn =<< getCurrentDirectory
|
|
logPutStrLn $ "link_dirs new="++new++", old="++old
|
|
#ifdef mingw32_HOST_OS
|
|
isDir <- doesDirectoryExist old
|
|
if isDir then removeDir old else removeFile old
|
|
writeFile old new -- poor man's symbolic links
|
|
#else
|
|
isLink <- isSymbolicLink `fmap` getSymbolicLinkStatus old
|
|
logPutStrLn $ "old is link: "++show isLink
|
|
if isLink then removeLink old else removeDir old
|
|
createSymbolicLink new old
|
|
#endif
|
|
return $ ok200 ""
|
|
where
|
|
old = takeFileName olddir
|
|
new = takeFileName newdir
|
|
link_directories olddir newdir =
|
|
err $ resp400 $ "unacceptable directories "++olddir++" "++newdir
|
|
|
|
grammarList dir qs =
|
|
do pgfs <- ls_ext dir ".pgf"
|
|
return $ jsonp qs pgfs
|
|
|
|
ls_ext dir ext =
|
|
do paths <- getDirectoryContents dir
|
|
return [path | path<-paths, takeExtension path==ext]
|
|
|
|
-- * Dynamic content
|
|
|
|
jsonresult cwd dir cmd (ecode,stdout,stderr) files =
|
|
makeObj [
|
|
"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"
|
|
_ -> ""
|
|
|
|
rel = unlines . map relative . lines
|
|
|
|
-- remove absolute file paths from error messages:
|
|
relative s = case stripPrefix cwd s of
|
|
Just ('/':rest) -> rest
|
|
_ -> s
|
|
|
|
-- * Static content
|
|
|
|
serveStaticFile rpath path =
|
|
do --logPutStrLn $ "Serving static file "++path
|
|
b <- doesDirectoryExist path
|
|
if b
|
|
then if rpath `elem` ["","."] || last path=='/'
|
|
then serveStaticFile' (path </> "index.html")
|
|
else return (resp301 ('/':rpath++"/"))
|
|
else serveStaticFile' path
|
|
|
|
serveStaticFile' path =
|
|
do let ext = takeExtension path
|
|
(t,rdFile) = contentTypeFromExt ext
|
|
if ext `elem` [".cgi",".fcgi",".sh",".php"]
|
|
then return $ resp400 $ "Unsupported file type: "++ext
|
|
else do b <- doesFileExist path
|
|
if b then fmap (ok200' (ct t "")) $ rdFile path
|
|
else do cwd <- getCurrentDirectory
|
|
logPutStrLn $ "Not found: "++path++" cwd="++cwd
|
|
return (resp404 path)
|
|
|
|
-- * Logging
|
|
logPutStrLn s = ePutStrLn s
|
|
|
|
-- * JSONP output
|
|
|
|
jsonp qs = maybe json200 apply (lookup "jsonp" qs)
|
|
where
|
|
apply f = jsonp200' $ \ json -> f++"("++json++")"
|
|
|
|
-- * Standard HTTP responses
|
|
ok200 = Response 200 [plainUTF8,noCache,xo] . encodeString
|
|
ok200' t = Response 200 [t,xo]
|
|
json200 x = json200' id x
|
|
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"
|
|
resp501 msg = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n"
|
|
|
|
instance Error Response where
|
|
noMsg = resp500 "no message"
|
|
strMsg = resp500
|
|
|
|
-- * Content types
|
|
plain = ct "text/plain" ""
|
|
plainUTF8 = ct "text/plain" csutf8
|
|
jsonUTF8 = ct "application/json" csutf8 -- http://www.ietf.org/rfc/rfc4627.txt
|
|
jsonpUTF8 = ct "application/javascript" csutf8
|
|
htmlUTF8 = ct "text/html" csutf8
|
|
|
|
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
|
|
".html" -> text "html"
|
|
".htm" -> text "html"
|
|
".xml" -> text "xml"
|
|
".txt" -> text "plain"
|
|
".css" -> text "css"
|
|
".js" -> text "javascript"
|
|
".png" -> bin "image/png"
|
|
".jpg" -> bin "image/jpg"
|
|
_ -> bin "application/octet-stream"
|
|
where
|
|
text subtype = ("text/"++subtype++"; charset=UTF-8",
|
|
fmap encodeString . readFile)
|
|
bin t = (t,readBinaryFile)
|
|
|
|
-- * IO utilities
|
|
updateFile path new =
|
|
do old <- try $ readBinaryFile path
|
|
-- let new = encodeString new0
|
|
when (Right new/=old) $ do logPutStrLn $ "Updating "++path
|
|
seq (either (const 0) length old) $
|
|
writeBinaryFile path new
|
|
|
|
-- | Check that a path is not outside the current directory
|
|
ok_access path =
|
|
case path of
|
|
'/':_ -> False
|
|
'.':'.':'/':_ -> False
|
|
_ -> not ("/../" `isInfixOf` path)
|
|
|
|
-- | Only delete files with these extensions
|
|
ok_to_delete = [".json",".gfstdoc",".gfo",".gf",".pgf"]
|
|
|
|
newDirectory =
|
|
do debug "newDirectory"
|
|
loop 10
|
|
where
|
|
loop 0 = fail "Failed to create a new directory"
|
|
loop n = maybe (loop (n-1)) return =<< once
|
|
|
|
once =
|
|
do k <- randomRIO (1,maxBound::Int)
|
|
let path = "tmp/gfse."++show k
|
|
b <- try $ createDirectory path
|
|
case b of
|
|
Left err -> do debug (show err) ;
|
|
if isAlreadyExistsError err
|
|
then return Nothing
|
|
else ioError err
|
|
Right _ -> return (Just ('/':path))
|
|
|
|
-- | Remove a directory and the files in it, but not recursively
|
|
removeDir dir =
|
|
do files <- filter (`notElem` [".",".."]) `fmap` getDirectoryContents dir
|
|
mapM (removeFile . (dir</>)) files
|
|
removeDirectory dir
|
|
|
|
setDir path =
|
|
do --logPutStrLn $ "cd "++show path
|
|
setCurrentDirectory path
|
|
|
|
{-
|
|
-- * direct-fastcgi deficiency workaround
|
|
|
|
--toHeader = FCGI.toHeader -- not exported, unfortuntately
|
|
|
|
toHeader "Content-Type" = FCGI.HttpContentType -- to avoid duplicate headers
|
|
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
|
|
|
|
inputs ('?':q) = decodeQuery q
|
|
inputs q = decodeQuery q
|
|
|
|
{-
|
|
-- Stay clear of queryToArgument, which uses unEscapeString, which had
|
|
-- backward incompatible changes in network-2.4.1.1, see
|
|
-- https://github.com/haskell/network/commit/f2168b1f8978b4ad9c504e545755f0795ac869ce
|
|
inputs = queryToArguments . fixplus
|
|
where
|
|
fixplus = concatMap decode
|
|
decode '+' = "%20" -- httpd-shed bug workaround
|
|
decode c = [c]
|
|
-}
|
|
|
|
mapFst f xys = [(f x,y)|(x,y)<-xys]
|
|
mapSnd f xys = [(x,f y)|(x,y)<-xys]
|
|
mapBoth = map . apBoth
|
|
apBoth f (x,y) = (f x,f y)
|
|
apSnd f (x,y) = (x,f y)
|
|
|
|
infix 1 .=
|
|
n .= v = (n,showJSON v)
|