Add flag --document-root for user with gf --server

This can make it easier to test cloud service updates before installing them.

3 files changed, 13 insertions, 5 deletions

diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 4ed283302..d07a96112 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -75,7 +75,7 @@ errors = fail . unlines
 -- Types
 
 data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
-          | ModeServer Int{-port-}
+          | ModeServer {-port::-}Int
   deriving (Show,Eq,Ord)
 
 data Verbosity = Quiet | Normal | Verbose | Debug
@@ -152,6 +152,7 @@ data Flags = Flags {
       optGFODir          :: Maybe FilePath,
       optOutputDir       :: Maybe FilePath,
       optGFLibPath       :: Maybe FilePath,
+      optDocumentRoot    :: Maybe FilePath, -- For --server mode
       optRecomp          :: Recomp,
       optProbsFile       :: Maybe FilePath,
       optRetainResource  :: Bool,
@@ -249,6 +250,7 @@ defaultFlags = Flags {
       optGFODir          = Nothing,
       optOutputDir       = Nothing,
       optGFLibPath       = Nothing,
+      optDocumentRoot    = Nothing,
       optRecomp          = RecompIfNewer,
       optProbsFile       = Nothing,
       optRetainResource  = False,
@@ -292,6 +294,8 @@ optDescr =
      Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
      Option [] ["server"] (OptArg modeServer "port") $
        "Run in HTTP server mode on given port (default "++show defaultPort++").",
+     Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
+           "Overrides the default document root for --server mode.",
      Option [] ["tags"] (NoArg (set $ \o -> o{optMode = ModeCompiler, optTagsOnly = True})) "Build TAGS file and exit.",
      Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
      Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
@@ -394,6 +398,7 @@ optDescr =
        lexicalCat  x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
        outDir      x = set $ \o -> o { optOutputDir = Just x }
        gfLibPath   x = set $ \o -> o { optGFLibPath = Just x }
+       gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
 
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index cccbbce39..f2afa9b78 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -71,8 +71,11 @@ shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files)
 
 #ifdef SERVER_MODE
 mainServerGFI opts0 port files =
-    server port (execute1 opts) =<< runSIO (importInEnv emptyGFEnv opts files)
-  where opts = beQuiet opts0
+    server port root (execute1 opts)
+      =<< runSIO (importInEnv emptyGFEnv opts files)
+  where
+    root = flag optDocumentRoot opts
+    opts = beQuiet opts0
 #else
 mainServerGFI opts files =
   error "GF has not been compiled with server mode support"
diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs
index ac14804c0..a6e4c5a52 100644
--- a/src/compiler/GFServer.hs
+++ b/src/compiler/GFServer.hs
@@ -47,12 +47,12 @@ import RunHTTP(cgiHandler)
 debug s = logPutStrLn s
 
 -- | Combined FastCGI and HTTP server
-server port execute1 state0 = 
+server port optroot execute1 state0 =
   do --stderrToFile logFile
      state <- newMVar M.empty
      cache <- PS.newPGFCache
      datadir <- getDataDir
-     let root = datadir</>"www"
+     let root = maybe (datadir</>"www") id optroot
 --   debug $ "document root="++root
      setCurrentDirectory root
 --   FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache)