{-# OPTIONS -fglasgow-exts -XUndecidableInstances #-}{- | A version of @Data.TCache@ using @TMVar@s instead of @TVars@s. See @Control.Concurrent.TMVar@
-}moduleData.TCache.TMVar(IResource(..)-- class interface to be implemented for the object by the user,Resources(..)-- data definition used to communicate object Inserts and Deletes to the cache,resources-- empty resources,getTMVars-- :: (IResource a)=> [a] -- the list of resources to be retrieved-- -> IO [Maybe (TMVar a)] -- The Transactional variables,getTMVarsIO-- :: (IResource a)=> [a] -> IO [TMVar a],withSTMResources-- :: (IResource a)=> [a] -- list of resources to retrieve-- -> ([Maybe a]-> Res a x) -- the function to apply that contains a Res structure-- -> STM x -- return value within the STM monad,withResources-- :: (IResource a)=> [a] --list of resources to be retrieve-- -> ([Maybe a]-> [a]) ----function that get the retrieved resources-- -> IO () --and return a list of objects to be inserted/modified ,withResource-- :: (IResource a)=> a --same as withResources , but for one only object-- -> ([Maybe a]-> a) ---- -> IO () --,getResources-- :: (IResource a)=>[a] --resources [a] are read from cache and returned-- -> IO [Maybe a] ,getResource-- :: :: (IResource a)=>a --to retrieve one object instead of a list-- -> IO [Maybe a] ,deleteResources-- :: (IResource a)=>[a]-> IO() -- delete the list of resources from cache and from persistent storage,deleteResource-- :: (IResource a)=>a-> IO() -- delete the resource from cache and from persistent storage--cache handling,Cache-- :: IORef (Ht a,Int, Integer) --The cache definition ,setCache-- :: Cache a -> IO() -- set the cache. this is useful for hot loaded modules that will use an existing cache,newCache-- :: (Ht a, Integer) --newCache creates a new cache ,refcache-- :: Cache a --the reference to the cache (see data definition below),syncCache-- :: (IResource a) =>Cache a -> IO() --force the atomic write of all the cache objects into permanent storage--useful for termination--start the thread that clean and writes on the persistent storage trough syncCache,clearSyncCacheProc-- :: (IResource a) =>Cache a --The cache reference -- -> Int --number of seconds betwen checks-- -> (Integer-> Integer-> Bool) --The user-defined check-for-cleanup-from-cache for each object --(when True, the object is removed from cache)-- -> Int --The max number of objects in the cache, if more, the cleanup start-- -> >IO ThreadId --Identifier of the thread created-- the default check procedure,defaultCheck-- :: Integer -- current time in seconds-- -> Integer --last access time for a given object-- -> Integer --last cache syncronization (with the persisten storage)-- -> Bool --return true for all the elems not accesed since --half the time between now and the last sync-- auxiliary,readFileStrict-- :: String -> IO String -- Strict file read, needed for the default file persistence )whereimportGHC.ConcimportControl.Concurrent.STM.TMVarimportControl.Monad(when)importData.HashTableasHimportData.IORefimportSystem.IO.UnsafeimportSystem.TimeimportData.Maybe(catMaybes,mapMaybe)importDebug.TraceimportData.TCache.IResourceimportControl.Exception(handle,assert)importData.List(nubBy,deleteFirstsBy)debugab=tracebatypeBlocka=(TMVara,AccessTime,ModifTime)typeHta=HashTableString(Blocka)-- contains the hastable, number of items, last sync timetypeCachea=IORef(Hta,Integer)dataCheckBlockFlags=AddToHash|NoAddToHash|MaxTime-- |set the cache. this is useful for hot loaded modules that will update an existing cachesetCache::(Hta,Integer)->IO()setCachech=writeIORefrefcachech-- the cache holder. stablished by defaultrefcache::Cachearefcache=unsafePerformIO$doc<-newCachenewIORefc-- | newCache creates a new cache newCache::IO(Hta,Integer)newCache=doc<-H.new(==)hashStringreturn(c,0)-- | getTMVars return the TMVar that wraps the resources for which the keys are given . -- | it return Nothing if a TMVar with this object has not been allocated-- These TMVars can be used in explicit user constructed atomic blocks-- Additionally, the TMVars remain in the cache and can be accessed and updated by the rest-- of the TCache methods. -- the content of the TMVars are written every time the cache is syncronized with the storage until releaseTMVars is called-- :: (IResource a)=> [a] -- the list of resources to be retrieved-- -> IO [Maybe (TMVar a)] -- The Transactional variables getTMVars::(IResourcea)=>[a]->STM[Maybe(TMVara)]getTMVarsrs=do(cache,_)<-unsafeIOToSTM$readIORefrefcachetakeBlocksrscacheMaxTime-- | releaseTMVars permits the TMVars captured by getTMVars to be released. so they can be discarded when not used-- Use this when you no longer need to use them directly in atomic blocks.releaseTMVars::(IResourcea)=>[a]->STM()releaseTMVarsrs=do(cache,_)<-unsafeIOToSTM$readIORefrefcachereleaseBlocksrscache-- | getTMVarsIO does not search for a TMVar in the cache like getTMVars. Instead of this getTMVarsIO creates a list of -- TMVars with the content given in the list of resourcees and add these TMVars to the cache and return them.-- the content of the TMVars are written every time the cache is syncronized with the storage until releaseTMVars is calledgetTMVarsIO::(IResourcea)=>[a]->IO[TMVara]getTMVarsIOrs=dotvs<-mapMnewTMVarIOrs(cache,_)<-readIORefrefcachemapM_(\(tv,r)->H.updatecache(keyResourcer)(tv,infinite,infinite))$ziptvsrsreturntvs-- | this is the main function for the *Resources primitivas, all the rest derive from it. the Res structure processed by the -- with*Resources primitives are more efficient for cached TMVars because the internal loop is never retried, since all the necessary-- resources at the beginning so no costly retries are necessary. The advantage increases with the complexity of the process-- function passed to withSTMResources is interpreted as such:-- -toUpdate secton is used to update the retrieved resources in the same order. -- if the resource don´t exist, it is created. Nothing means do nothing as usual. extra resources are not considered,-- it uses the rules of zip.-- -toAdd: additional resources not read in the first parameter of withSTMResources are created/updated with toAdd-- -toDelete: obvious-- -toReturn: will be returned by the callwithSTMResources::(IResourcea)=>[a]-- ^ the list of resources to be retrieved->([Maybea]->Resourcesax)-- ^ The function that process the resources found and return a Resources structure->STMx-- ^ The return value in the STM monad.withSTMResourcesrsf=do(cache,_)<-unsafeIOToSTM$readIORefrefcachemtrs<-takeBlocksrscacheNoAddToHashmrs<-mapMmreadTMVarmtrscasefmrsofRetry->retryResourcesasdsr->dounsafeIOToSTM$dodelListFromHashcache$mapkeyResourcedsmapMdelResourcedsreleaseBlocksascachereturnrwheremreadTMVar(Justtvar)=dor<-takeTMVartvarreturn$JustrmreadTMVarNothing=returnNothing-- | update of a single object in the cache-- :: (IResource a)=> a same as withResources , but for one only object-- -> ([Maybe a]-> a) -- -> IO () withResource::(IResourcea)=>a->(Maybea->a)->IO()withResourcerf=withResources[r](\[mr]->[fmr])-- | to atomically add/modify many objects in the cache-- :: (IResource a)=> [a] list of resources to be retrieve-- -> ([Maybe a]-> [a]) function that process the retrieved resources-- -> IO () and return a list of objects to be inserted/modified withResources::(IResourcea)=>[a]->([Maybea]->[a])->IO()withResourcesrsf=atomically$withSTMResourcesrsf1>>return()wheref1mrs=letas=fmrsinResourcesas[]()-- | to read a resource from the cachegetResourcer=do{mr<-getResources[r];return$!headmr}---to read a list of resources from the cache if they exist-- :: (IResource a)=>[a] resources [a] are read from cache and returned-- -> IO [Maybe a] the resultgetResources::(IResourcea)=>[a]->IO[Maybea]getResourcesrs=atomically$withSTMResourcesrsf1wheref1mrs=Resources[][]mrs-- | delete the resource from cache and from persistent storagedeleteResourcer=deleteResources[r]-- | delete the list of resources from cache and from persistent storagedeleteResourcesrs=atomically$withSTMResourcesrsf1wheref1mrs=Resources[](catMaybesmrs)()takeBlocks::(IResourcea)=>[a]->Hta->CheckBlockFlags->STM[Maybe(TMVara)]takeBlocksrscacheaddToHash=mapM(checkBlockcacheaddToHash)rswherecheckBlock::IResourcea=>Hta->CheckBlockFlags->a->STM(Maybe(TMVara))checkBlockcacheflagsr=doc<-unsafeIOToSTM$H.lookupcachekeyrcasecofNothing->domr<-unsafeIOToSTM$readResourcer-- `debug` ("read "++keyr++ " hash= "++ (show $ H.hashString keyr))casemrofNothing->returnNothingJustr2->dotvr<-newTMVarr2caseflagsofNoAddToHash->return$JusttvrAddToHash->doti<-unsafeIOToSTMtimeIntegerunsafeIOToSTM$H.updatecachekeyr(tvr,ti,0)-- accesed, not modifiedreturn$JusttvrMaxTime->dounsafeIOToSTM$H.updatecachekeyr(tvr,infinite,infinite)-- accesed, not modifiedreturn$JusttvrJust(tvr,_,_)->return$Justtvrwherekeyr=keyResourcerreleaseBlocks::(IResourcea)=>[a]->Hta->STM()releaseBlocksrscache=mapM_checkBlockrswherecheckBlockr=doc<-unsafeIOToSTM$H.lookupcachekeyrcasecofNothing->dotvr<-newTMVarrti<-unsafeIOToSTMtimeIntegerunsafeIOToSTM$H.updatecachekeyr(tvr,ti,ti)-- accesed and modified XXXJust(tvr,_,tm)->doti<-unsafeIOToSTMtimeIntegerlett=maxtitmtry<-tryPutTMVartvrr--putTMVar tvr rcasetryofFalse->doswapTMVartvrr;return()True->return()unsafeIOToSTM$H.updatecachekeyr(tvr,t,t)wherekeyr=keyResourcertimeInteger=doTODt_<-getClockTimereturntdelListFromHashhashl=do{mapM(deletehash)l;return()}updateListToHashhashkv=do{mapM(update1hash)kv;return()}whereupdate1h(k,v)=updatehkv-----------------------clear, sync cache--------------- | start the thread that clean and writes on the persistent storage. -- Otherwise, clearSyncCache must be invoked explicitly or no persistence will exist-- :: (IResource a) =>Cache a --The cache reference -- -> Int --number of seconds betwen checks-- -> (Integer-> Integer-> Bool) --The user-defined check-for-cleanup-from-cache for each object --(when this function return True, the object is removed from cache)-- -> Int --The max number of objects in the cache, if more, the cleanup start-- -> >IO ThreadId --Identifier of the thread createdclearSyncCacheProc::(IResourcea)=>Cachea->Int->(Integer->Integer->Integer->Bool)->Int->IOThreadIdclearSyncCacheProcrefcachetimechecksizeObjects=forkIOclearwhereclear=dothreadDelay$(fromIntegral$time*1000000)clearSyncCacherefcachetimechecksizeObjectsclear-- | force the atomic write of all the cached objects into permanent storage-- useful for terminationsyncCacherefcache=do(cache,t1)<-readIORefrefcachelist<-toListcachet2<-timeIntegeratomically$savelistt1writeIORefrefcache(cache,t2)--print $ "write to persistent storage finised: "++ show (length list)++ " objects" -- | Saves the unsaved elems of the cache-- delete some elems of the cache when the number of elems > sizeObjects-- The deletion depends on the check criteria. defaultCheck is the one implementedclearSyncCache::(IResourcea)=>Cachea->Int->(Integer->Integer->Integer->Bool)->Int->IO()clearSyncCacherefcachetimechecksizeObjects=do(cache,lastSync)<-readIORefrefcachehandle(\e->do{printe;return()})$doelems<-toListcacheletsize=lengthelemsatomically$saveelemslastSynct<-timeIntegerwhen(size>sizeObjects)(filtercachetcachelastSyncelems)writeIORefrefcache(cache,t)where-- delete elems from the cache according with the check criteriafiltercachetcachelastSyncelems=mapM_filterelemswherecheck1(_,lastAccess,_)=checktlastAccesslastSyncfilter::(String,Blocka)->IOIntfilter(k,e)=ifcheck1ethendo{H.deletecachek;return1}elsereturn0-- | To drop from the cache all the elems not accesed since half the time between now and the last sync-- the default check procedure-- :: Integer -- current time in seconds-- -> Integer --last access time for a given object-- -> Integer --last cache syncronization (with the persisten storage)-- -> Bool --return true for all the elems not accesed since --half the time between now and the last syncdefaultCheck::Integer->Integer->Integer->BooldefaultChecknowlastAccesslastSync|lastAccess>halftime=False|otherwise=Truewherehalftime=now-(now-lastSync)`div`2save::(IResourcea)=>[(String,Blocka)]->Integer->STM()savelistlastSave=mapM_save1list--`debug` ("saving "++ (show $ length list))wheresave1::IResourcea=>(String,Blocka)->STM()save1(_,(tvr,_,modTime))=doifmodTime>=lastSave--`debug` ("modTime="++show modTime++"lastSave="++show lastSave)thendor<-readTMVartvrunsafeIOToSTM$!writeResourcer--`debug` ("saved " ++ keyResource r)elsereturn()