mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
d1da0e06de
Most PGF web API commands that produce linearizations now accept an unlexer parameter. Possible values are "text", "code" and "mixed". The web service now include Date and Last-Modified headers in the HTTP, responses. This means that browsers can treat responses as static content and cache them, so it becomes less critical to cache parse results in the server. Also did some cleanup in PGFService.hs, e.g. removed a couple of functions that can now be imported from PGF.Lexing instead.
42 lines
1.5 KiB
Haskell
42 lines
1.5 KiB
Haskell
module Cache (Cache,newCache,flushCache,readCache,readCache') where
|
|
|
|
import Control.Concurrent.MVar
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
import System.Directory (getModificationTime)
|
|
import Data.Time (UTCTime)
|
|
import Data.Time.Compat (toUTCTime)
|
|
|
|
data Cache a = Cache {
|
|
cacheLoad :: FilePath -> IO a,
|
|
cacheObjects :: MVar (Map FilePath (MVar (Maybe (UTCTime, a))))
|
|
}
|
|
|
|
newCache :: (FilePath -> IO a) -> IO (Cache a)
|
|
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 = snd `fmap` readCache' c file
|
|
|
|
readCache' :: Cache a -> FilePath -> IO (UTCTime,a)
|
|
readCache' c file =
|
|
do v <- modifyMVar (cacheObjects c) findEntry
|
|
modifyMVar v readObject
|
|
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)
|
|
-- Check time stamp, and reload if different than the cache entry
|
|
readObject m = do t' <- toUTCTime `fmap` getModificationTime file
|
|
x' <- case m of
|
|
Just (t,x) | t' == t -> return x
|
|
_ -> cacheLoad c file
|
|
return (Just (t',x'), (t',x'))
|