PGF service: expire PGFs from the cache when they have been unused for 24 hours

...to keep memory use down on the server.

src/server/Cache.hs

@@ -1,33 +1,55 @@
-module Cache (Cache,newCache,flushCache,listCache,readCache,readCache') where
+-- | A file cache to avoid reading and parsing the same file many times
+module Cache (Cache,newCache,flushCache,expireCache,listCache,readCache,readCache') where
 
 import Control.Concurrent.MVar
 import Data.Map (Map)
 import qualified Data.Map as Map 
+import Data.Foldable as T(mapM_)
+import Data.Maybe(mapMaybe)
 import System.Directory (getModificationTime)
 import System.Mem(performGC)
-import Data.Time (UTCTime)
+import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
 import Data.Time.Compat (toUTCTime)
 
 data Cache a = Cache {
       cacheLoad :: FilePath -> IO a,
-      cacheObjects :: MVar (Map FilePath (MVar (Maybe (UTCTime, a))))
+      cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
     }
 
+type FileInfo a = (UTCTime,UTCTime,a) -- modification time, access time, contents
+
+-- | Create a new cache that uses the given function to read and parse files
 newCache :: (FilePath -> IO a) -> IO (Cache a)
 newCache load = 
     do objs <- newMVar Map.empty
        return $ Cache { cacheLoad = load, cacheObjects = objs }
 
+-- | Forget all cached objects
 flushCache :: Cache a -> IO ()
 flushCache c = do modifyMVar_ (cacheObjects c) (const (return Map.empty))
                   performGC
 
-listCache :: Cache a -> IO [FilePath]
-listCache = fmap Map.keys . readMVar . cacheObjects
+-- | Forget cached objects that have been unused for longer than the given time
+expireCache age c =
+  do now <- getCurrentTime
+     let expire object@(Just (_,t,_)) | diffUTCTime now t>age = return Nothing
+         expire object = return object
+     withMVar (cacheObjects c) (T.mapM_ (flip modifyMVar_ expire))
+     performGC
 
+-- | List currently cached files
+listCache :: Cache a -> IO [FilePath]
+listCache c =
+    fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
+  where
+    check (path,v) = maybe Nothing (const (Just path)) `fmap` readMVar v
+
+-- | Lookup a cached object (or read the file if it is not in the cache or if
+-- it has been modified)
 readCache :: Cache a -> FilePath -> IO a
 readCache c file = snd `fmap` readCache' c file
 
+-- | Like 'readCache', but also return the last modification time of the file
 readCache' :: Cache a -> FilePath -> IO (UTCTime,a)
 readCache' c file =
     do v <- modifyMVar (cacheObjects c) findEntry
@@ -40,7 +62,8 @@ readCache' c file =
                                      return (Map.insert file v objs, v)
     -- Check time stamp, and reload if different than the cache entry
     readObject m = do t' <- toUTCTime `fmap` getModificationTime file
+                      now <- getCurrentTime
                       x' <- case m of
-                        Just (t,x) | t' == t -> return x
-                        _                    -> cacheLoad c file
-                      return (Just (t',x'), (t',x'))
+                              Just (t,_,x) | t' == t -> return x
+                              _                      -> cacheLoad c file
+                      return (Just (t',now,x'), (t',x'))

src/server/PGFService.hs

@@ -53,21 +53,28 @@ type Caches = (Cache PGF,Cache (C.PGF,({-MVar ParseCache-})))
 --type ParseCache = Map.Map (String,String) (ParseResult,UTCTime)
 --type ParseResult = Either String [(C.Expr,Float)]
 
-newPGFCache = do pgfCache <- newCache PGF.readPGF
-                 cCache <- newCache $ \ path -> do pgf <- C.readPGF path
-                                                 --pc <- newMVar Map.empty
-                                                   return (pgf,({-pc-}))
+newPGFCache = do pgfCache <- newCache' PGF.readPGF
+                 cCache <- newCache' $ \ path -> do pgf <- C.readPGF path
+                                                  --pc <- newMVar Map.empty
+                                                    return (pgf,({-pc-}))
                  return (pgfCache,cCache)
 flushPGFCache (c1,c2) = flushCache c1 >> flushCache c2
 listPGFCache (c1,c2) = (,) # listCache c1 % listCache c2
 #else
 type Caches = (Cache PGF,())
-newPGFCache = do pgfCache <- newCache PGF.readPGF
+newPGFCache = do pgfCache <- newCache' PGF.readPGF
                  return (pgfCache,())
 flushPGFCache (c1,_) = flushCache c1
 listPGFCache (c1,_) = (,) # listCache c1 % return []
 #endif
 
+newCache' rd = do c <- newCache rd
+                  forkIO $ forever $ clean c
+                  return c
+  where
+    clean c = do threadDelay 2000000000 -- 2000 seconds, i.e. ~33 minutes
+                 expireCache (24*60*60) c -- 24 hours
+
 getPath =
     do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi
        if null path

src/server/gf-server.cabal

@@ -21,8 +21,8 @@ flag c-runtime
   Default:     False
 
 Library
-  exposed-modules: PGFService FastCGIUtils ServeStaticFile RunHTTP
-  other-modules: Cache URLEncoding Fold
+  exposed-modules: PGFService FastCGIUtils ServeStaticFile RunHTTP Cache
+  other-modules: URLEncoding Fold
   hs-source-dirs: . transfer
 
   build-depends:   base >=4.2 && <5,