From f211fc10cad9b9bf719c4305afee4e1e9eaecac0 Mon Sep 17 00:00:00 2001
From: bjorn <bjorn@bringert.net>
Date: Thu, 16 Oct 2008 13:00:44 +0000
Subject: [PATCH] Multithreaded gf.fcgi.

---
 src/server/FastCGIUtils.hs | 31 ++++++++++++++++++-------------
 src/server/MainFastCGI.hs  | 17 +++++++++--------
 src/server/gf-server.cabal |  1 +
 3 files changed, 28 insertions(+), 21 deletions(-)

diff --git a/src/server/FastCGIUtils.hs b/src/server/FastCGIUtils.hs
index e95cad3f5..1b75403d5 100644
--- a/src/server/FastCGIUtils.hs
+++ b/src/server/FastCGIUtils.hs
@@ -104,21 +104,26 @@ restartIfModified =
 -- Utilities for getting and caching read-only data from disk.
 -- The data is reloaded when the file on disk has been modified.
 
-type DataRef a = IORef (Maybe (ClockTime, a))
+data DataRef a = DataRef {
+      dataFile :: FilePath,
+      dataLoad :: FilePath -> IO a,
+      dataValue :: MVar (ClockTime, a)
+    }
 
-newDataRef :: MonadIO m => m (DataRef a)
-newDataRef = liftIO $ newIORef Nothing
+newDataRef :: (FilePath -> IO a) -> FilePath -> IO (DataRef a)
+newDataRef load file = 
+    do t <- getModificationTime file
+       x <- load file
+       v <- newMVar (t,x)
+       return $ DataRef { dataFile = file, dataLoad = load, dataValue = v }
 
-getData :: MonadIO m => (FilePath -> m a) -> DataRef a -> FilePath -> m a
-getData loadData ref file = 
-    do t' <- liftIO $ getModificationTime file
-       m <- liftIO $ readIORef ref
-       case m of
-         Just (t,x) | t' == t -> return x
-         _                    -> do logCGI $ "Loading " ++ show file ++ "..."
-                                    x <- loadData file
-                                    liftIO $ writeIORef ref (Just (t',x))
-                                    return x
+getData :: DataRef a -> IO a
+getData ref = 
+    do t' <- getModificationTime (dataFile ref)
+       (t,x) <- takeMVar (dataValue ref)
+       x' <- if t' == t then return x else (dataLoad ref) (dataFile ref)
+       putMVar (dataValue ref) (t',x')
+       return x'
 
 -- Logging
 
diff --git a/src/server/MainFastCGI.hs b/src/server/MainFastCGI.hs
index ed3e8278e..b36014840 100644
--- a/src/server/MainFastCGI.hs
+++ b/src/server/MainFastCGI.hs
@@ -5,28 +5,29 @@ import qualified PGF
 import FastCGIUtils
 import URLEncoding
 
-import Network.CGI
+import Network.FastCGI
 import Text.JSON
 import qualified Codec.Binary.UTF8.String as UTF8 (encodeString, decodeString)
 
+import Control.Concurrent
 import Control.Monad
 import Data.Char
 import qualified Data.Map as Map
 import Data.Maybe
+import System.Environment
 
 
-grammarFile :: FilePath
-grammarFile = "grammar.pgf"
-
-
+grammarFile :: IO FilePath
+grammarFile = do env <- getEnvironment
+                 return $ fromMaybe "grammar.pgf" $ lookup "PGF_FILE" env
 
 main :: IO ()
 main = do initFastCGI
-          r <- newDataRef
-          loopFastCGI (handleErrors (handleCGIErrors (fcgiMain r)))
+          ref <- grammarFile >>= newDataRef PGF.readPGF
+          runFastCGIConcurrent' forkIO 100 (handleErrors (handleCGIErrors (fcgiMain ref)))
 
 fcgiMain :: DataRef PGF -> CGI CGIResult
-fcgiMain ref = getData (liftIO . PGF.readPGF) ref grammarFile >>= cgiMain
+fcgiMain ref = liftIO (getData ref) >>= cgiMain
 
 cgiMain :: PGF -> CGI CGIResult
 cgiMain pgf =
diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal
index afbad3283..2256e5cfe 100644
--- a/src/server/gf-server.cabal
+++ b/src/server/gf-server.cabal
@@ -20,3 +20,4 @@ executable gf.fcgi
   main-is: MainFastCGI.hs
   other-modules:
     FastCGIUtils
+  ghc-options: -threaded
\ No newline at end of file