gf -server: add a command to manually flush the PGF cache

This can be used if the cloud service seems slow, but it would probably
be better to automatically expire unused PGFs from the cache after some time.

3 files changed, 8 insertions, 2 deletions

diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs
index dc805906f..cad43a97d 100644
--- a/src/compiler/GFServer.hs
+++ b/src/compiler/GFServer.hs
@@ -152,6 +152,7 @@ handle logLn documentroot state0 cache execute1 stateVar
 --         "/start"   ->
            "/parse"   -> parse (decoded qs)
            "/version" -> return (ok200 gf_version)
+           "/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.
diff --git a/src/server/Cache.hs b/src/server/Cache.hs
index d704fe495..8cb9135e2 100644
--- a/src/server/Cache.hs
+++ b/src/server/Cache.hs
@@ -1,4 +1,4 @@
-module Cache (Cache,newCache,readCache) where
+module Cache (Cache,newCache,flushCache,readCache) where
 
 import Control.Concurrent.MVar
 import Data.Map (Map)
@@ -17,6 +17,9 @@ newCache load =
     do objs <- newMVar Map.empty
        return $ Cache { cacheLoad = load, cacheObjects = objs }
 
+flushCache :: Cache a -> IO ()
+flushCache c = modifyMVar_ (cacheObjects c) (const (return Map.empty))
+
 readCache :: Cache a -> FilePath -> IO a
 readCache c file = 
     do v <- modifyMVar (cacheObjects c) findEntry
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 752035e87..2ca9b4ca2 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP #-}
 module PGFService(cgiMain,cgiMain',getPath,
                   logFile,stderrToFile,
-                  newPGFCache) where
+                  newPGFCache,flushPGFCache) where
 
 import PGF (PGF)
 import qualified PGF
@@ -51,10 +51,12 @@ newPGFCache = do pgfCache <- newCache PGF.readPGF
                                                    pc <- newMVar Map.empty
                                                    return (pgf,pc)
                  return (pgfCache,cCache)
+flushPGFCache (c1,c2) = flushCache c1 >> flushCache c2
 #else
 type Caches = (Cache PGF,())
 newPGFCache = do pgfCache <- newCache PGF.readPGF
                  return (pgfCache,())
+flushPGFCache (c1,_) = flushCache c1
 #endif
 
 getPath =