when in server mode reuse the NGF cache in the shell as well

src/server/Cache.hs

@@ -6,12 +6,14 @@ 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.Directory (getModificationTime, canonicalizePath)
+import System.FilePath (makeRelative)
 import System.Mem(performGC)
 import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
 --import Data.Time.Compat (toUTCTime)
 
 data Cache a = Cache {
+      cacheRoot :: FilePath,
       cacheLoad :: Maybe a -> FilePath -> IO a,
       cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
     }
@@ -19,10 +21,13 @@ data Cache a = Cache {
 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 :: (Maybe a -> FilePath -> IO a) -> IO (Cache a)
-newCache load = 
-    do objs <- newMVar Map.empty
-       return $ Cache { cacheLoad = load, cacheObjects = objs }
+newCache :: FilePath -> (Maybe a -> FilePath -> IO a) -> IO (Cache a)
+newCache root load = do
+  objs <- newMVar Map.empty
+  return (Cache { cacheRoot = root
+                , cacheLoad = load
+                , cacheObjects = objs
+                })
 
 -- | Forget all cached objects
 flushCache :: Cache a -> IO ()
@@ -40,11 +45,10 @@ expireCache age c =
 -- | List currently cached files
 listCache :: Cache a -> IO [(FilePath,UTCTime)]
 listCache c =
-    fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
+  fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
   where
     check (path,v) = maybe Nothing (Just . (,) path . fst3) `fmap` readMVar v
-
-fst3 (x,y,z) = x
+    fst3 (x,y,z) = x
 
 -- | Lookup a cached object (or read the file if it is not in the cache or if
 -- it has been modified)
@@ -53,20 +57,24 @@ 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
-       modifyMVar v readObject
+readCache' c file = do
+  file <- canonicalizePath file
+  v <- modifyMVar (cacheObjects c)
+                  (findEntry (makeRelative (cacheRoot c) file))
+  modifyMVar v (readObject file)
   where
     -- Find the cache entry, inserting a new one if neccessary.
-    findEntry objs = case Map.lookup file objs of
-                       Just v -> return (objs,v)
-                       Nothing -> do v <- newMVar Nothing
-                                     return (Map.insert file v objs, v)
+    findEntry file objs = case Map.lookup file objs of
+                            Just v  -> return (objs,v)
+                            Nothing -> do v <- newMVar Nothing
+                                          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
-                                           | otherwise -> cacheLoad c (Just x) file
-                              _                        -> cacheLoad c Nothing  file
-                      return (Just (t',now,x'), (t',x'))
+    readObject file m = do
+      t'  <- getModificationTime file
+      now <- getCurrentTime
+      x' <- case m of
+              Just (t,_,x) | t' == t   -> return x
+                           | otherwise -> cacheLoad c (Just x) file
+              _                        -> cacheLoad c Nothing  file
+      return (Just (t',now,x'), (t',x'))

src/server/PGFService.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE CPP #-}
 module PGFService(cgiMain,cgiMain',getPath,
                   logFile,stderrToFile,
-                  Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
+                  Caches,newPGFCache,readCachedPGF,readCachedNGF,
+                  flushPGFCache,listPGFCache) where
 
 import PGF2
 import PGF2.Transactions
@@ -44,28 +45,33 @@ logFile = "pgf-error.log"
 
 data Caches = Caches { qsem :: QSem,
                        pgfCache :: Cache PGF,
+                       ngfCache :: Cache PGF,
                        labelsCache :: Cache Labels }
 
-newPGFCache jobs = do let n = maybe 4 id jobs
-                      qsem <- newQSem n
-                      pgfCache <- newCache' readGrammar
-                      lblCache <- newCache' (const (fmap getDepLabels . readFile))
-                      return $ Caches qsem pgfCache lblCache
+newPGFCache root jobs = do
+  let n = maybe 4 id jobs
+  qsem <- newQSem n
+  pgfCache <- newCache' root (const readPGF)
+  ngfCache <- newCache' root (maybe readNGF (const . checkoutPGF))
+  lblCache <- newCache' root (const (fmap getDepLabels . readFile))
+  return $ Caches qsem pgfCache ngfCache lblCache
+
+readCachedPGF :: Caches -> FilePath -> IO PGF
+readCachedPGF = readCache . pgfCache
+
+readCachedNGF :: Caches -> FilePath -> IO PGF
+readCachedNGF = readCache . ngfCache
+
 flushPGFCache c = do flushCache (pgfCache c)
+                     flushCache (ngfCache c)
                      flushCache (labelsCache c)
-listPGFCache c = listCache (pgfCache c)
 
-readGrammar mb_pgf path =
-  case takeExtension path of
-    ".pgf" -> readPGF path
-    ".ngf" -> case mb_pgf of
-                Nothing -> readNGF path
-                Just gr -> checkoutPGF gr
-    _      -> error "Extension must be .pgf or .ngf"
+listPGFCache c = liftM2 (++) (listCache (pgfCache c)) (listCache (ngfCache c))
 
-newCache' rd = do c <- newCache rd
-                  forkIO $ forever $ clean c
-                  return c
+newCache' root rd = do 
+  c <- newCache root 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
@@ -86,15 +92,20 @@ cgiMain' cache path =
                         (getInput "command")
        case command of
          "download" -> outputBinary =<< getFile BS.readFile path
-         _ -> do tpgf <- getFile (readCache' (pgfCache cache)) path
+         _ -> do let get = case takeExtension path of
+                             ".pgf" -> pgfCache
+                             ".ngf" -> ngfCache
+                             _      -> error "Extension must be .pgf or .ngf"
+                 tpgf <- getFile (readCache' (get cache)) path
                  pgfMain (qsem cache) command tpgf
-
-getFile get path =
-   either failed return =<< liftIO (E.try (get path))
-  where
-    failed e = if isDoesNotExistError e
-               then notFound path
-               else liftIO $ ioError e
+    where
+      getFile get path =
+        either failed return =<< liftIO (E.try (get path))
+        where
+          failed e = 
+            if isDoesNotExistError e
+              then notFound path
+              else liftIO $ ioError e
 
 
 pgfMain qsem command (t,pgf) =

src/server/pgf-fcgi.hs

@@ -5,8 +5,7 @@ import Network.FastCGI
 import PGFService(cgiMain,newPGFCache,stderrToFile,logFile)
 
 main = do stderrToFile logFile
-          fcgiMain =<< newPGFCache Nothing
-
+          fcgiMain =<< newPGFCache "" Nothing
 
 fcgiMain cache =
 #ifndef mingw32_HOST_OS

src/server/pgf-service.cabal

@@ -15,8 +15,8 @@ flag network-uri
    default: True
 
 Library
-  exposed-modules: PGFService URLEncoding CGIUtils Cache
-
+  exposed-modules: PGFService URLEncoding CGIUtils
+  other-modules:   Cache
   build-depends:   base >=4.2 && <5,
                    time,
                    directory,