Rename modules GFI, GFC & GFServer...

... to GF.Interactive, GF.Compiler & GF.Server, respectively.

1 files changed, 0 insertions, 494 deletions

diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs
deleted file mode 100644
index fbcca3d94..000000000
--- a/src/compiler/GFServer.hs
+++ /dev/null
@@ -1,494 +0,0 @@
--- | 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)