(fastcgi) replace DataRef with a more general Cache type, which can hold several PGF grammars.

src/server/Cache.hs

@@ -0,0 +1,36 @@
+module Cache (Cache,newCache,readCache) where
+
+import Control.Concurrent
+import Data.Map (Map)
+import qualified Data.Map as Map 
+import System.Directory (getModificationTime)
+import System.Time (ClockTime)
+
+data Cache a = Cache {
+      cacheLoad :: FilePath -> IO a,
+      cacheObjects :: MVar (Map FilePath (MVar (ClockTime, a)))
+    }
+
+newCache :: (FilePath -> IO a) -> IO (Cache a)
+newCache load = 
+    do objs <- newMVar Map.empty
+       return $ Cache { cacheLoad = load, cacheObjects = objs }
+
+readCache :: Cache a -> FilePath -> IO a
+readCache c file = 
+    do t' <- getModificationTime file
+       objs <- takeMVar (cacheObjects c)
+       case Map.lookup file objs of
+         -- object is in cache
+         Just v  -> do (t,x) <- takeMVar v
+                       putMVar (cacheObjects c) objs
+                       -- check timestamp
+                       x' <- if t == t' then return x else cacheLoad c file
+                       putMVar v (t',x')
+                       return x'
+         -- first time this object is requested
+         Nothing -> do v <- newEmptyMVar
+                       putMVar (cacheObjects c) (Map.insert file v objs)
+                       x' <- cacheLoad c file
+                       putMVar v (t',x')
+                       return x'

src/server/FastCGIUtils.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module FastCGIUtils (initFastCGI, loopFastCGI,
-                     DataRef, newDataRef, getData,
                      throwCGIError, handleCGIErrors) where
 
 import Control.Concurrent
@@ -17,7 +16,6 @@ import System.IO.Unsafe
 import System.Posix
 import System.Time
 
-
 import Network.FastCGI
 
 initFastCGI :: IO ()
@@ -101,30 +99,6 @@ restartIfModified =
                          -- FIXME: setCurrentDirectory?
                          executeFile prog False args Nothing
 
--- Utilities for getting and caching read-only data from disk.
--- The data is reloaded when the file on disk has been modified.
-
-data DataRef a = DataRef {
-      dataFile :: FilePath,
-      dataLoad :: FilePath -> IO a,
-      dataValue :: MVar (ClockTime, a)
-    }
-
-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 :: 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
 
 logError :: String -> IO ()

src/server/MainFastCGI.hs

@@ -2,6 +2,7 @@
 
 import PGF (PGF)
 import qualified PGF
+import Cache
 import FastCGIUtils
 import URLEncoding
 
@@ -17,17 +18,18 @@ import Data.Maybe
 import System.Environment
 
 
-grammarFile :: IO FilePath
+defaultGrammarFile :: IO FilePath
-grammarFile = do env <- getEnvironment
+defaultGrammarFile = 
-                 return $ fromMaybe "grammar.pgf" $ lookup "PGF_FILE" env
+    do env <- getEnvironment
+       return $ fromMaybe "grammar.pgf" $ lookup "PGF_FILE" env
 
 main :: IO ()
 main = do initFastCGI
-          ref <- grammarFile >>= newDataRef PGF.readPGF
+          cache <- newCache PGF.readPGF
-          runFastCGIConcurrent' forkIO 100 (handleErrors (handleCGIErrors (fcgiMain ref)))
+          runFastCGIConcurrent' forkIO 100 (handleErrors (handleCGIErrors (fcgiMain cache)))
 
-fcgiMain :: DataRef PGF -> CGI CGIResult
+fcgiMain :: Cache PGF -> CGI CGIResult
-fcgiMain ref = liftIO (getData ref) >>= cgiMain
+fcgiMain cache = liftIO (defaultGrammarFile >>= readCache cache) >>= cgiMain
 
 cgiMain :: PGF -> CGI CGIResult
 cgiMain pgf =

src/server/gf-server.cabal

@@ -20,4 +20,6 @@ executable pgf.fcgi
   main-is: MainFastCGI.hs
   other-modules:
     FastCGIUtils
+    Cache
+    URLEncoding
   ghc-options: -threaded