fastcgi: better grammar cache implementation: don't deadlock on exceptions

src/server/Cache.hs

@@ -1,6 +1,6 @@
 module Cache (Cache,newCache,readCache) where
 
-import Control.Concurrent
+import Control.Concurrent.MVar
 import Data.Map (Map)
 import qualified Data.Map as Map 
 import System.Directory (getModificationTime)
@@ -8,7 +8,7 @@ import System.Time (ClockTime)
 
 data Cache a = Cache {
       cacheLoad :: FilePath -> IO a,
-      cacheObjects :: MVar (Map FilePath (MVar (ClockTime, a)))
+      cacheObjects :: MVar (Map FilePath (MVar (Maybe (ClockTime, a))))
     }
 
 newCache :: (FilePath -> IO a) -> IO (Cache a)
@@ -18,19 +18,17 @@ newCache load =
 
 readCache :: Cache a -> FilePath -> IO a
 readCache c file = 
-    do t' <- getModificationTime file
+    do v <- modifyMVar (cacheObjects c) findEntry
-       objs <- takeMVar (cacheObjects c)
+       modifyMVar v readObject
-       case Map.lookup file objs of
+  where
-         -- object is in cache
+    -- Find the cache entry, inserting a new one if neccessary.
-         Just v  -> do (t,x) <- takeMVar v
+    findEntry objs = case Map.lookup file objs of
-                       putMVar (cacheObjects c) objs
+                       Just v -> return (objs,v)
-                       -- check timestamp
+                       Nothing -> do v <- newMVar Nothing
-                       x' <- if t == t' then return x else cacheLoad c file
+                                     return (Map.insert file v objs, v)
-                       putMVar v (t',x')
+    -- Check time stamp, and reload if different than the cache entry
-                       return x'
+    readObject m = do t' <- getModificationTime file
-         -- first time this object is requested
+                      x' <- case m of
-         Nothing -> do v <- newEmptyMVar
+                        Just (t,x) | t' == t -> return x
-                       putMVar (cacheObjects c) (Map.insert file v objs)
+                        _                    -> cacheLoad c file
-                       x' <- cacheLoad c file
+                      return (Just (t',x'), x')
-                       putMVar v (t',x')
-                       return x'