summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF.hs2
-rw-r--r--src/compiler/GF/Infra/Option.hs2
-rw-r--r--src/compiler/GFI.hs20
-rw-r--r--src/compiler/GFServer.hs148
4 files changed, 167 insertions, 5 deletions
diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs
index 503253589..43a2a0b7f 100644
--- a/src/compiler/GF.hs
+++ b/src/compiler/GF.hs
@@ -45,5 +45,5 @@ mainOpts opts files =
ModeHelp -> putStrLn helpMessage
ModeInteractive -> mainGFI opts files
ModeRun -> mainRunGFI opts files
+ ModeServer -> mainServerGFI opts files
ModeCompiler -> dieIOE (mainGFC opts files)
-
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 9c8925f3d..1560f315f 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -74,6 +74,7 @@ errors = fail . unlines
-- Types
data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
+ | ModeServer
deriving (Show,Eq,Ord)
data Verbosity = Quiet | Normal | Verbose | Debug
@@ -293,6 +294,7 @@ optDescr =
Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
+ Option [] ["server"] (NoArg (mode ModeServer)) "Run in HTTP server mode.",
Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index 8d89f146c..bec2e3b0e 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, CPP #-}
-module GFI (mainGFI,mainRunGFI) where
+module GFI (mainGFI,mainRunGFI,mainServerGFI) where
import GF.Command.Interpreter
import GF.Command.Importing
@@ -44,6 +44,9 @@ import Control.Monad
import Data.Version
import Text.PrettyPrint (render)
import GF.System.Signal
+#ifdef SERVER_MODE
+import GFServer(server)
+#endif
--import System.IO.Error (try)
#ifdef mingw32_HOST_OS
import System.Win32.Console
@@ -53,9 +56,9 @@ import System.Win32.NLS
import Paths_gf
mainRunGFI :: Options -> [FilePath] -> IO ()
-mainRunGFI opts files = do
- let opts1 = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) opts
- shell opts1 files
+mainRunGFI opts files = shell (beQuiet opts) files
+
+beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do
@@ -64,6 +67,15 @@ mainGFI opts files = do
shell opts files = loop opts =<< importInEnv emptyGFEnv opts files
+#ifdef SERVER_MODE
+mainServerGFI opts0 files =
+ server (execute1 opts) =<< importInEnv emptyGFEnv opts files
+ where opts = beQuiet opts0
+#else
+mainServerGFI opts files =
+ error "GF has not been compiled with server mode support"
+#endif
+
-- | Read end execute commands until it is time to quit
loop :: Options -> GFEnv -> IO ()
loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv
diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs
new file mode 100644
index 000000000..75ff7bd3d
--- /dev/null
+++ b/src/compiler/GFServer.hs
@@ -0,0 +1,148 @@
+module GFServer(server) where
+import Data.List(partition)
+import qualified Data.Map as M
+import Control.Monad(when)
+import System.Random(randomRIO)
+import System.IO(stdout,stderr)
+import System.IO.Error(try,ioError)
+import System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
+ setCurrentDirectory,getCurrentDirectory)
+import System.FilePath(takeExtension,(</>))
+import Control.Concurrent.MVar(newMVar,modifyMVar)
+import Network.URI(URI(..))
+import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments,
+ noCache)
+import System.IO.Silently(hCapture)
+import Codec.Binary.UTF8.String(encodeString)
+import GF.Infra.UseIO(readBinaryFile)
+
+-- * Configuraiton
+port = 41295
+documentRoot = "."
+
+-- * HTTP server
+server execute1 state0 =
+ do state <- newMVar M.empty
+ putStrLn $ "Starting server on port "++show port
+ initServer port (modifyMVar state . handle state0 execute1)
+
+-- * HTTP request handler
+handle state0 execute1 (Request method URI{uriPath=path,uriQuery=q} hdrs body) state =
+ do let qs = decodeQ $
+ case method of
+ "GET" -> queryToArguments q
+ "POST" -> queryToArguments body
+
+ logPutStrLn $ method++" "++path++" "++show qs
+ case path of
+ "/new" -> new
+-- "/stop" ->
+-- "/start" ->
+ "/gfshell" -> inDir qs $ look "command" . command
+ "/upload" -> inDir qs upload
+ '/':rpath -> do resp <- serveStaticFile (translatePath rpath)
+ return (state,resp)
+ _ -> return (state,resp400 path)
+ where
+ 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")
+
+ inDir qs ok = look "dir" cd qs
+ where
+ cd ('/':dir@('t':'m':'p':_)) qs' =
+ do cwd <- getCurrentDirectory
+ b <- try $ setCurrentDirectory dir
+ case b of
+ Left _ -> return (state,resp404 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)
+ let state' = maybe state (flip (M.insert dir) state) st'
+ return (state',ok200 output)
+
+ upload dir files=
+ do let update (name,contents)= updateFile (name++".gf") contents
+ mapM_ update files
+ return (state,resp204)
+
+-- * Static content
+
+translatePath path = documentRoot</>path -- hmm, check for ".."
+
+serveStaticFile path =
+ do b <- doesDirectoryExist path
+ let path' = if b then path </> "index.html" else path
+ serveStaticFile' path'
+
+serveStaticFile' path =
+ do b <- doesFileExist path
+ let (t,rdFile,encode) = contentTypeFromExt (takeExtension path)
+ if b then fmap (ok200' (ct t) . encode) $ rdFile path
+ else return (resp404 path)
+
+-- * Logging
+logPutStrLn = putStrLn
+
+-- * Standard HTTP responses
+ok200 body = Response 200 [plainUTF8,noCache] (encodeString body)
+ok200' t body = Response 200 [t] body
+resp204 = Response 204 [] "" -- no content
+resp400 msg = Response 400 [plain] $ "Bad request: "++msg++"\n"
+resp404 path = Response 404 [plain] $ "Not found: "++path++"\n"
+
+-- * Content types
+plain = ct "text/plain"
+plainUTF8 = ct "text/plain; charset=UTF-8"
+ct t = ("Content-Type",t)
+
+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",readFile,encodeString)
+ bin t = (t,readBinaryFile,id)
+
+-- * IO utilities
+updateFile path new =
+ do old <- try $ readFile path
+ when (Right new/=old) $ do logPutStrLn $ "Updating "++path
+ seq (either (const 0) length old) $
+ writeFile path new
+
+
+newDirectory =
+ do k <- randomRIO (1,maxBound::Int)
+ let path = "tmp/gfse."++show k
+ b <- try $ createDirectory path
+ case b of
+ Left _ -> newDirectory
+ Right _ -> return ('/':path)
+
+-- * misc utils
+
+decodeQ qs = [(decode n,decode v)|(n,v)<-qs]
+decode = map decode1
+decode1 '+' = ' ' -- httpd-shed bug workaround
+decode1 c = c
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 11:03:53 +0000