msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

the server must checkout the grammar if an .ngf file changes

Browse Source
This commit is contained in:
Krasimir Angelov
2022-06-16 18:20:18 +02:00
parent ad8a32ce86
commit 8ac0d881ed
2 changed files with 11 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/server/Cache.hs
View File

@@ -12,14 +12,14 @@ import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
--import Data.Time.Compat (toUTCTime) --import Data.Time.Compat (toUTCTime)
data Cache a = Cache { data Cache a = Cache {
cacheLoad :: FilePath -> IO a, cacheLoad :: Maybe a -> FilePath -> IO a,
cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a)))) cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
} }
type FileInfo a = (UTCTime,UTCTime,a) -- modification time, access time, contents 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 -- | Create a new cache that uses the given function to read and parse files
newCache :: (FilePath -> IO a) -> IO (Cache a) newCache :: (Maybe a -> FilePath -> IO a) -> IO (Cache a)
newCache load = newCache load =
do objs <- newMVar Map.empty do objs <- newMVar Map.empty
return $ Cache { cacheLoad = load, cacheObjects = objs } return $ Cache { cacheLoad = load, cacheObjects = objs }
@@ -66,6 +66,7 @@ readCache' c file =
readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file
now <- getCurrentTime now <- getCurrentTime
x' <- case m of x' <- case m of
Just (t,_,x) | t' == t -> return x Just (t,_,x) | t' == t -> return x
_ -> cacheLoad c file | otherwise -> cacheLoad c (Just x) file
_ -> cacheLoad c Nothing file
return (Just (t',now,x'), (t',x')) return (Just (t',now,x'), (t',x'))

9
src/server/PGFService.hs
View File

@@ -4,6 +4,7 @@ module PGFService(cgiMain,cgiMain',getPath,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
import PGF2 import PGF2
import PGF2.Transactions
import GF.Text.Lexing import GF.Text.Lexing
import Cache import Cache
import CGIUtils(outputJSONP,outputPlain,outputHTML,outputText, import CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
@@ -60,16 +61,18 @@ data Caches = Caches { qsem :: QSem,
newPGFCache jobs = do let n = maybe 4 id jobs newPGFCache jobs = do let n = maybe 4 id jobs
qsem <- newQSem n qsem <- newQSem n
pgfCache <- newCache' readGrammar pgfCache <- newCache' readGrammar
lblCache <- newCache' (fmap getDepLabels . readFile) lblCache <- newCache' (const (fmap getDepLabels . readFile))
return $ Caches qsem pgfCache lblCache return $ Caches qsem pgfCache lblCache
flushPGFCache c = do flushCache (pgfCache c) flushPGFCache c = do flushCache (pgfCache c)
flushCache (labelsCache c) flushCache (labelsCache c)
listPGFCache c = listCache (pgfCache c) listPGFCache c = listCache (pgfCache c)
readGrammar path = readGrammar mb_pgf path =
case takeExtension path of case takeExtension path of
".pgf" -> readPGF path ".pgf" -> readPGF path
".ngf" -> readNGF path ".ngf" -> case mb_pgf of
Nothing -> readNGF path
Just gr -> putStrLn "CHECKOUT!!!" >> checkoutPGF gr
_ -> error "Extension must be .pgf or .ngf" _ -> error "Extension must be .pgf or .ngf"
newCache' rd = do c <- newCache rd newCache' rd = do c <- newCache rd