TCache 0.6.5 → 0.8.0
raw patch · 9 files changed
+1268/−1590 lines, 9 filesdep +transformersdep −RefSerializedep ~base
Dependencies added: transformers
Dependencies removed: RefSerialize
Dependency ranges changed: base
Files
- Data/TCache.hs +821/−412
- Data/TCache/Dynamic.hs +0/−226
- Data/TCache/FilePersistence.hs +23/−0
- Data/TCache/IDynamic.hs +0/−159
- Data/TCache/IResource.hs +0/−190
- Data/TCache/IndexQuery.hs +388/−0
- Data/TCache/TMVar.hs +0/−378
- Data/TCache/TMVar/Dynamic.hs +0/−183
- TCache.cabal +36/−42
Data/TCache.hs view
@@ -1,412 +1,821 @@-{-# OPTIONS -fglasgow-exts -XUndecidableInstances #-} - - -------------------------------------------------- --- A Transactional data cache with configurable persitence --- (Something like a little Java Hybernate or Rails for Rubi) --- Author: Alberto G�mez Corona Nov 2006 --- Language: Haskell --- Terms of use: See LICENSE --- 2008:--- some bugs fixed --- 10/15/2007 : changes --- Default writeResource and delResource for persistence in files --- (only keyResource must be defined by the user if use defaults) --- Coherent Inserts and deletes --- Reduced the number of accesses to the hashtable --- hashtable access put outside of the transaction block (takeBlocks) --- faster re-executions in case of roll-back - ------------------------------------------------- - - -module Data.TCache ( - - 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 - -,getTVars -- :: (IResource a)=> [a] -- the list of resources to be retrieved- -- -> IO [Maybe (TVar a)] -- The Transactional variables--,releaseTVars- -,getTVarsIO -- :: (IResource a)=> [a] -> IO [TVar a] - -,withSTMResources -- :: (IResource a)=> [a] -- list of resources to retrieve - -- -> ([Maybe a]-> Resources a x) -- the function to apply that contains a Resources 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 - - -) -where - - -import GHC.Conc -import Control.Concurrent.STM.TMVar -import Control.Monad(when) -import Data.HashTable as H -import Data.IORef -import System.IO.Unsafe -import System.Time -import Data.Maybe(catMaybes,mapMaybe) - -import Data.TCache.IResource -import Control.Exception(handle,assert) - - - - -type Block a= (TVar a,AccessTime,ModifTime) -type Ht a= HashTable String (Block a) --- contains the hastable, number of items, last sync time -type Cache a= IORef (Ht a, Integer) -data CheckBlockFlags= AddToHash | NoAddToHash | MaxTime ---- |set the cache. this is useful for hot loaded modules that will update an existing cache. Experimental-setCache :: (Ht a, Integer) -> IO()-setCache = writeIORef refcache- --- the cache holder. stablished by default -refcache :: Cache a -refcache =unsafePerformIO $ newCache >>= newIORef - --- | newCache creates a new cache. Experimental -newCache :: IO (Ht a, Integer) -newCache =do - c <- H.new (==) hashString - return (c,0) - --- | getTVars return the TVar that wraps the resources for which the keys are given . --- | it return @Nothing@ if a TVar with this object has not been allocated --- These TVars can be used as usual in explicit user constructed atomic blocks --- Additionally, the retrieved TVars remain in the cache and can be accessed and updated by the rest --- of the TCache methods. --- to keep the consistence in the serialized data, the content of the TVars are written every time the cache is syncronized with the storage until releaseTVars is called - -getTVars- :: (IResource a)- => [a] -- ^ the list of partial object definitions for which keyResource can be extracted- -> STM [Maybe (TVar a)] -- ^ The TVars that contain such objects-getTVars rs= do- (cache,_) <- unsafeIOToSTM $ readIORef refcache - takeBlocks rs cache MaxTime - --- | releaseTVars permits the TVars captured by getTVars to be released. so they can be discarded when not used. --- Do this when you no longer need to use them directly in atomic blocks. -releaseTVars :: (IResource a)=> [a]-> STM () -releaseTVars rs=do - (cache,_) <- unsafeIOToSTM $ readIORef refcache - releaseBlocks rs cache - --- | getTVarsIO does not search for a TVar in the cache like getTVars. Instead of this getTVarsIO creates a list of --- TVars with the content given in the list of resourcees and add these TVars to the cache and return them. --- the content of the TVars are written every time the cache is syncronized with the storage until releaseTVars is called -getTVarsIO :: (IResource a)=> [a] -> IO [TVar a] -getTVarsIO rs= do - tvs<- mapM newTVarIO rs - (cache,_) <- readIORef refcache - mapM_ (\(tv,r)-> H.update cache (keyResource r) (tv, infinite, infinite)) $ zip tvs rs - return tvs - - --- | this is the main function for the *Resource calls. All the rest derive from it. The results are kept in the STM monad--- so it can be part of a larger STM transaction involving other TVars--- The 'Resources' register returned by the user-defined function is interpreted as such:--- --- 'toAdd': additional resources not read in the first parameter of withSTMResources are created/updated with toAdd ------ 'toDelete': from the cache and from permanent storage--- --- 'toReturn': will be returned by withSTMResources - - -withSTMResources :: (IResource a)=> [a] -- ^ the list of resources to be retrieved - -> ([Maybe a]-> Resources a x) -- ^ The function that process the resources found and return a Resources structure - -> STM x -- ^ The return value in the STM monad. -withSTMResources rs f= do - (cache,_) <- unsafeIOToSTM $ readIORef refcache - mtrs <- takeBlocks rs cache AddToHash - - mrs <- mapM mreadTVar mtrs - case f mrs of- Retry -> retry- Resources as ds r -> do - unsafeIOToSTM $ do- delListFromHash cache $ map keyResource ds- mapM delResource ds - releaseBlocks as cache - return r - - where - assert1= flip assert - - mreadTVar (Just tvar)= readTVar tvar >>= return . Just - mreadTVar Nothing = return Nothing - - --- | update of a single object in the cache------ @withResource r f= withResources [r] (\[mr]-> [f mr])@ -withResource:: (IResource a)- => a -- ^ prototypes of the object to be retrieved for which keyResource can be derived- -> (Maybe a-> a) -- ^ update function that return another full object- -> IO () -withResource r f= withResources [r] (\[mr]-> [f mr]) ----- | to atomically add/modify many objects in the cache--- --- @ withResources rs f= atomically $ withSTMResources rs f1 >> return() where f1 mrs= let as= f mrs in Resources as [] ()@-withResources:: (IResource a)=> [a]-> ([Maybe a]-> [a])-> IO () -withResources rs f= atomically $ withSTMResources rs f1 >> return() where - f1 mrs= let as= f mrs in Resources as [] ()- --- | to read a resource from the cache.------ @getResource r= do{mr<- getResources [r];return $! head mr}@-getResource:: (IResource a)=>a-> IO (Maybe a) -getResource r= do{mr<- getResources [r];return $! head mr} - ---- | to read a list of resources from the cache if they exist--- --- | @getResources rs= atomically $ withSTMResources rs f1 where f1 mrs= Resources [] [] mrs@ -getResources:: (IResource a)=>[a]-> IO [Maybe a] -getResources rs= atomically $ withSTMResources rs f1 where - f1 mrs= Resources [] [] mrs - - --- | delete the resource from cache and from persistent storage.------ @ deleteResource r= deleteResources [r] @-deleteResource :: IResource a => a -> IO () -deleteResource r= deleteResources [r] - --- | delete the list of resources from cache and from persistent storage.--- --- @ deleteResources rs= atomically $ withSTMResources rs f1 where f1 mrs = Resources [] (catMaybes mrs) ()@ -deleteResources :: IResource a => [a] -> IO ()-deleteResources rs= atomically $ withSTMResources rs f1 where - f1 mrs = Resources [] (catMaybes mrs) () - - --takeBlocks :: (IResource a)=> [a] -> Ht a -> CheckBlockFlags -> STM [Maybe (TVar a)]-takeBlocks rs cache addToHash= mapM (checkBlock cache addToHash) rs - where- checkBlock :: IResource a => Ht a -> CheckBlockFlags -> a-> STM(Maybe (TVar a)) - checkBlock cache flags r =do - c <- unsafeIOToSTM $ H.lookup cache keyr - case c of - Nothing -> do - mr <- unsafeIOToSTM $ readResource r -- `debug` ("read "++keyr++ " hash= "++ (show $ H.hashString keyr)) - case mr of - Nothing -> return Nothing - Just r2 -> do - tvr <- newTVar r2 - case flags of - NoAddToHash -> return $ Just tvr - AddToHash -> do - ti <- unsafeIOToSTM timeInteger - unsafeIOToSTM $ H.update cache keyr (tvr, ti, 0) -- accesed, not modified - return $ Just tvr - - MaxTime -> do - unsafeIOToSTM $ H.update cache keyr (tvr, infinite, infinite) -- accesed, not modified - return $ Just tvr-- - - Just(tvr,_,_) -> return $ Just tvr - - where keyr= keyResource r -- -releaseBlocks :: (IResource a)=> [a] -> Ht a -> STM ()-releaseBlocks rs cache = mapM_ checkBlock rs - - where - checkBlock r =do - c <- unsafeIOToSTM $ H.lookup cache keyr - case c of - Nothing -> do- tvr <- newTVar r- ti <- unsafeIOToSTM timeInteger- unsafeIOToSTM $ H.update cache keyr (tvr, ti, ti ) -- accesed and modified XXX - - - Just(tvr,_,tm) -> do- writeTVar tvr r - ti <- unsafeIOToSTM timeInteger- let t= max ti tm- unsafeIOToSTM $ H.update cache keyr (tvr ,t,t) - - - - where keyr= keyResource r - - -timeInteger= do TOD t _ <- getClockTime - return t - - - -delListFromHash hash l=mapM_ (delete hash) l - -updateListToHash hash kv= mapM (update1 hash) kv where - update1 h (k,v)= update h k v - -{-| Cache handling -}- --- | 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 --- -> 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 created - -clearSyncCacheProc ::- (IResource a)- => Cache a -- ^ The cache reference ('refcache' usually)- -> Int -- ^ number of seconds betwen checks. objects not written to disk are written- -> (Integer -> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example- -> Int -- ^ The max number of objects in the cache, if more, the cleanup starts- -> IO ThreadId -- ^ Identifier of the thread created -clearSyncCacheProc refcache time check sizeObjects= - forkIO clear - - where- clear = do - threadDelay (fromIntegral$ time * 1000000) - clearSyncCache refcache time check sizeObjects - clear -saving= unsafePerformIO $ newTVarIO False- --- | Force the atomic write of all the cached objects into permanent storage --- useful for termination-syncCache- :: (IResource a)- => Cache a -- ^ the cache reference ( 'refcache' usually)- -> IO () -syncCache refcache = do- atomically $ do- s <- readTVar saving- when s retry- writeTVar saving True - (cache,t1) <- readIORef refcache - list <- toList cache - t2<- timeInteger - atomically $ save list t1 - writeIORef refcache (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 implemented -clearSyncCache ::(IResource a) => Cache a-> Int -> (Integer -> Integer-> Integer-> Bool)-> Int -> IO () -clearSyncCache refcache time check sizeObjects=do- atomically $ do- s <- readTVar saving- when s retry- writeTVar saving True - (cache,lastSync) <- readIORef refcache - handle (\e-> do{print e;return ()})$ do - elems <- toList cache - let size=length elems - atomically $ save elems lastSync - t<- timeInteger - when (size > sizeObjects) (filtercache t cache lastSync elems) - writeIORef refcache (cache, t) - - where - -- delete elems from the cache according with the check criteria - filtercache t cache lastSync elems= mapM_ filter elems - where - check1 (_,lastAccess,_)=check t lastAccess lastSync - - filter ::(String,Block a)-> IO Int - filter (k,e)= if check1 e then do{H.delete cache k;return 1} else return 0 - --- | To drop from the cache all the elems not accesed since half the time between now and the last sync --- ths is a default cache clearance procedure -- it is invoke when the cache size exceeds the defined in 'clearSyncCacheProc' -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 -defaultCheck now lastAccess lastSync - | lastAccess > halftime = False - | otherwise = True - - where - halftime= now- (now-lastSync) `div` 2 - - -- -save:: (IResource a) => [(String, Block a)]-> Integer-> STM () -save list lastSave= do- mapM_ save1 list -- `debug` ("saving "++ (show $ length list))- writeTVar saving False - where- save1 :: IResource a =>(String, Block a) -> STM() - save1(_, (tvr,_,modTime))= - when (modTime >= lastSave) $ do -- `debug` ("modTime="++show modTime++"lastSave="++show lastSave) - r<- readTVar tvr - unsafeIOToSTM $! writeResource r -- `debug` ("saved " ++ keyResource r) - - - +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable+ , FlexibleInstances, UndecidableInstances #-}++{- | TCache is a transactional cache with configurable persitence that permits+STM transactions with objects thar syncronize sincromous or asyncronously with+their user defined storages. Default persistence in files is provided for testing purposes++In this release some stuff has been supressed without losing functionality. Dynamic interfaces+are not needed since TCache can handle heterogeneous data.+The new things in this release, besides the backward compatible stuf are:++ TCache now implements. ''DBRef' 's . They are persistent STM references with a traditional 'readDBRef', 'writeDBRef' Haskell interface.+simitar to TVars, but with aded. persistence+Additionally, because DBRefs are serializable, they can be embeded in serializable registers.+Because they are references,they point to other serializable registers.+This permits persistent mutable Inter-object relations++Triggers are user defined hooks that are called back on register updates. That can be used for:++ - ease the work of maintain actualized the inter-object relations++ - permit more higuer level and customizable accesses ++"Data.TCache.IndexQuery" implements an straighforwards pure haskell type safe query language based+ on register field relations. This module must be imported separately.+ see "Data.TCache.IndexQuery" for further information++The file persistence is now more reliable, and the embedded IO reads inside STM transactions are safe.++To ease the implementation of other user-defined persistence, "Data.TCache.FIlePersistence" must be imported+ for deriving file persistence instances+++-}++ + + +module Data.TCache ( +-- * Inherited from 'Control.Concurrent.STM'++ atomically+ ,STM++-- * operations with cached database references+{-| DBRefs are persistent cached database references in the STM monad+with read/write primitives, so the traditional syntax of Haskell STM references+can be used for interfacing with databases. As expected, the DBRefs are transactional,+ because they operate in the STM monad.++DBRefs are references to cached database objects. A DBRef is associated with its referred object and its key+Since DBRefs are serializable, they can be elements of mutable objects. They could point to other mutable objects+and so on, so DBRefs can act as "hardwired" relations from mutable objects+to other mutable objects in the database/cache. their referred objects are loaded, saved and flused+to and from the cache automatically depending on the cache handling policies and the access needs+++DBRefs are univocally identified by its pointed object keys, so they can be compared, ordered and so on.+The creation of a DBRef, trough 'getDBRef' is pure. This permits an efficient lazy marshalling+of registers with references, such are indexes when are queried for some fields but not others.++Example: Car registers have references to Person regiters++@+data Person= Person {pname :: String} deriving (Show, Read, Eq, Typeable)+data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)+@+++Here the Car register point to the Person register trough the owner field++To permit persistence and being refered with DBRefs, define the Indexable instance+for these two register types:++@+instance Indexable Person where key Person{pname= n} = "Person " ++ n+instance Indexable Car where key Car{cname= n} = "Car " ++ n+@++Now we create a DBRef to a Person whose name is \"Bruce\"++>>> let bruce = getDBRef . key $ Person "Bruce" :: DBRef Person++>>> show bruce+>"DBRef \"Person bruce\""++>>> atomically (readDBRef bruce)+>Nothing++'getDBRef' is pure and creates the reference, but not the referred object;+To create both the reference and the DBRef, use 'newDBRef'.+Lets create two Car's and its two Car DBRefs with bruce as owner:++>>> cars <- atomically $ mapM newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"]++>>> print cars+>[DBRef "Car Bat Mobile",DBRef "Car Porsche"]++>>> carRegs<- atomically $ mapM readDBRef cars+> [Just (Car {owner = DBRef "Person bruce", cname = "Bat Mobile"})+> ,Just (Car {owner = DBRef "Person bruce", cname = "Porsche"})]++try to write with 'writeDBRef'++>>> atomically . writeDBRef bruce $ Person "Other"+>*** Exception: writeDBRef: law of key conservation broken: old , new= Person bruce , Person Other++DBRef's can not be written with objects of different keys++>>> atomically . writeDBRef bruce $ Person "Bruce"++>>> let Just carReg1= head carRegs++now from the Car register it is possible to recover the owner's register++>>> atomically $ readDBRef ( owner carReg1)+>Just (Person {pname = "bruce"})++++DBRefs, once the pointed cached object is looked up in the cache and found at creation, they does+not perform any further cache lookup afterwards, so reads and writes from/to DBRefs are faster+than *Resource(s) calls, which perform lookups everytime+in the cache++DBRef's and *Resource(s) primitives are completely interoperable. The latter operate implicitly with DBRef's++-}+++,DBRef+,getDBRef+,keyObjDBRef+,newDBRef+--,newDBRefIO+,readDBRef+,writeDBRef+,delDBRef++-- * IResource class+{- | cached objects must be instances of IResource.+Such instances can be implicitly derived trough auxiliary clasess for file persistence+-}+,IResource(..) -- class interface to be implemented for the object by the user +,Serializable(..) +,Indexable(..)++++-- * Operations with cached objects+{- | Operations with DBRef's can be performed implicitly with the \"traditional\" TCache operations+available in older versions.++In this example \"buy\" is a transaction where the user buy an item.+The spent amount is increased and the stock of the product is decreased:++@+data Data= User{uname::String, uid::String, spent:: Int} |+ Item{iname::String, iid::String, price::Int, stock::Int}+ deriving (Read, Show)++instance Indexable Data where+ key User{uid=id}= id+ key Item{iid=id}= id++user `buy` item= 'withResources'[user,item] buyIt+ where+ buyIt[Just us,Just it]+ | stock it > 0= [us',it']+ | otherwise = error \"stock is empty for this product\"++ where+ us'= us{spent=spent us + price it}+ it'= it{stock= stock it-1}++ buyIt _ = error \"either the user or the item (or both) does not exist\"+@+-}+,resources -- empty resources +,withSTMResources+,Resources(..) -- data definition used to communicate object Inserts and Deletes to the cache +,withResources +,withResource +,getResources +,getResource +,deleteResources +,deleteResource++-- * Trigger operations+{- | Trriggers are called just before an object of the given type is created, modified or deleted.+The DBRef to the object and the new value is passed to the trigger.+The called trigger function has two parameters: the DBRef being accesed+(which still contains the old value), and the new value.+If the content of the DBRef is being deleted, the second parameter is 'Nothing'.+if the DBRef contains Nothing, then the object is being created++Example:++every time a car is added, or deleted, the owner's list is updated+this is done by the user defined trigger addCar++@+ addCar pcar (Just(Car powner _ )) = addToOwner powner pcar+ addCar pcar Nothing = readDBRef pcar >>= \(Just car)-> deleteOwner (owner car) pcar++ addToOwner powner pcar=do+ Just owner <- readDBRef powner+ writeDBRef powner owner{cars= nub $ pcar : cars owner}++ deleteOwner powner pcar= do+ Just owner <- readDBRef powner+ writeDBRef powner owner{cars= delete pcar $ cars owner}++ main1= do+ 'addTrigger' addCar+ putStrLn \"create bruce's register with no cars\"+ bruce \<- 'atomically' 'newDBRef' $ Person \"Bruce\" []++ putStrLn "add two car register with \"bruce\" as owner using the reference to the bruces register"+ let newcars= [Car bruce \"Bat Mobile\" , Car bruce \"Porsche\"]+ insert newcars++ Just bruceData \<- atomically $ 'readDBRef' bruce+ putStrLn "the trigger automatically updated the car references of the Bruce register"+ print . length $ cars bruceData+ print bruceData+@+-}+,addTrigger+ +-- * cache control+,flushDBRef+,flushAll +,Cache +,setCache +,newCache +,refcache +,syncCache+,setConditions+,clearSyncCache +,numElems +,clearSyncCacheProc +,defaultCheck+-- * auxiliary file operations used for default persistence in files. +,readFileStrict+,defaultReadResource +,defaultReadResourceByKey+,defaultWriteResource+,defaultDelResource +) +where + + +import GHC.Conc +import Control.Monad(when) +import Data.HashTable as H +import Data.IORef +import System.IO.Unsafe +import System.IO(hPutStr, stderr) +import Data.Maybe(catMaybes,mapMaybe, fromMaybe, fromJust) ++import Data.TCache.Defs +import Data.TCache.IResource+import Data.TCache.Triggers +import Control.Exception(handle,assert, SomeException)+import Data.Typeable +import System.Time+import System.Mem+import System.Mem.Weak+import Debug.Trace++import Control.Concurrent.MVar +++++debug a b = trace b a+++-- there are two references to the DBRef here+-- The Maybe one keeps it alive until the cache releases it for *Resources+-- calls which does not reference dbrefs explicitly+-- The weak reference keeps the dbref alive until is it not referenced elsewere+data CacheElem= forall a.(IResource a,Typeable a) => CacheElem (Maybe (DBRef a)) (Weak(DBRef a))+ +type Ht = HashTable String CacheElem+ +-- contains the hastable, last sync time +type Cache = IORef (Ht , Integer) +data CheckTPVarFlags= AddToHash | NoAddToHash + +-- | set the cache. this is useful for hot loaded modules that will update an existing cache. Experimental +setCache :: Cache -> IO() +setCache ref = readIORef ref >>= \ch -> writeIORef refcache ch + +-- the cache holder. stablished by default +refcache :: Cache +refcache =unsafePerformIO $ newCache >>= newIORef + +-- | newCache creates a new cache. Experimental +newCache :: IO (Ht , Integer) +newCache =do + c <- H.new (==) hashString + return (c,0)++-- | return the total number of DBRefs in the cache. For debug purposes+-- This does not count the number of objects in the cache since many of the DBRef+-- may not have the pointed object loaded. Itś O(n).+numElems :: IO Int+numElems= do+ (cache, _) <- readIORef refcache+ elems <- toList cache + return $ length elems+++deRefWeakSTM = unsafeIOToSTM . deRefWeak++deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO ()+deleteFromCache (DBRef k tv)= do+ (cache, _) <- readIORef refcache+ H.delete cache k+++-- | return the reference value. If it is not in the cache, it is fetched+-- from the database.+readDBRef :: (IResource a, Typeable a) => DBRef a -> STM (Maybe a)+readDBRef dbref@(DBRef key tv)= do+ r <- readTVar tv+ case r of+ Exist (Elem x _ mt) -> do+ t <- unsafeIOToSTM timeInteger + writeTVar tv . Exist $ Elem x t mt+ return $ Just x+ DoNotExist -> return $ Nothing+ NotRead -> do+ r <- safeIOToSTM $ readResourceByKey key+ case r of+ Nothing -> writeTVar tv DoNotExist >> return Nothing+ Just x -> do+ t <- unsafeIOToSTM timeInteger+ writeTVar tv $ Exist $ Elem x t t+ return $ Just x++-- | write in the reference a value+-- The new key must be the same than the old key of the previous object stored+-- otherwise, an error "law of key conservation broken" will be raised+writeDBRef :: (IResource a, Typeable a) => DBRef a -> a -> STM ()+writeDBRef dbref@(DBRef key tv) x= do+ let newkey= keyResource x+ if newkey /= key+ then error $ "writeDBRef: law of key conservation broken: old , new= " ++ key ++ " , "++newkey+ else do+ applyTriggers [dbref] [Just x]+ t <- unsafeIOToSTM timeInteger+ writeTVar tv $ Exist $ Elem x t t+ return()+++++instance Show (DBRef a) where+ show (DBRef key _)= "DBRef \""++ key ++ "\""++instance (IResource a, Typeable a) => Read (DBRef a) where+ readsPrec n ('D':'B':'R':'e':'f':' ':'\"':str)=+ let (key,nstr) = break (== '\"') str+ in [( getDBRef key :: DBRef a, tail nstr)]+ readsPrec _ _ = []++instance Eq (DBRef a) where+ DBRef k _ == DBRef k' _ = k==k'++instance Ord (DBRef a) where+ compare (DBRef k _) (DBRef k' _) = compare k k'++-- | return the key of the object pointed to by the DBRef+keyObjDBRef :: DBRef a -> String+keyObjDBRef (DBRef k _)= k++ +-- | get the reference to the object in the cache. if it does not exist, the reference is created empty.+-- Every execution of 'getDBRef' returns the same unique reference to this key,+-- so it can be safely considered pure. This is a property useful because deserialization+-- of objects with unused embedded DBRef's do not need to marshall them eagerly+-- Tbis also avoid unnecesary cache lookups of the pointed objects.+getDBRef :: (Typeable a, IResource a) => String -> DBRef a+getDBRef key= unsafePerformIO $! getDBRef1 $! key where+ getDBRef1 :: (Typeable a, IResource a) => String -> IO (DBRef a)+ getDBRef1 key= do+ (cache,_) <- readIORef refcache+ r <- H.lookup cache key+ case r of+ Just (CacheElem _ w) -> do+ mr <- deRefWeak w+ case mr of+ Just dbref@(DBRef _ tv) -> return $ castErr dbref+ Nothing -> finalize w >> getDBRef1 key -- the weak pointer hasn executed his finalizer++ Nothing -> do + tv<- newTVarIO NotRead+ let dbref= DBRef key tv+ w <- mkWeakPtr dbref . Just $ deleteFromCache dbref + H.update cache key (CacheElem Nothing w) + return dbref+ +{- | Create the object passed as parameter (if it does not exist) and+-- return its reference in the IO monad.+-- If an object with the same key already exists, it is returned as is+-- If not, the reference is created with the new value.+-- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined +newDBRefIO :: (IResource a,Typeable a) => a -> IO (DBRef a) +newDBRefIO x= do+ let key = keyResource x + mdbref <- mDBRefIO key+ case mdbref of+ Right dbref -> return dbref++ Left cache -> do + tv<- newTVarIO DoNotExist+ let dbref= DBRef key tv+ w <- mkWeakPtr dbref . Just $ deleteFromCache dbref + H.update cache key (CacheElem Nothing w)+ t <- timeInteger+ atomically $ do+ applyTriggers [dbref] [Just x] --`debug` ("before "++key)+ writeTVar tv . Exist $ Elem x t t+ return dbref + +-} + + +-- get a single DBRef if exist +mDBRefIO + :: (IResource a, Typeable a) + => String -- ^ the list of partial object definitions for which keyResource can be extracted + -> IO (Either Ht (DBRef a)) -- ^ The TVars that contain such objects+mDBRefIO k= do + (cache,_) <- readIORef refcache+ r <- H.lookup cache k+ case r of+ Just (CacheElem _ w) -> do+ mr <- deRefWeak w+ case mr of+ Just dbref -> return . Right $ castErr dbref+ Nothing -> finalize w >> mDBRefIO k+ Nothing -> return $ Left cache + ++ +-- | Create the object passed as parameter (if it does not exist) and+-- return its reference in the STM monad.+-- If an object with the same key already exists, it is returned as is+-- If not, the reference is created with the new value.+-- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined+ +newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) +newDBRef x = do+ let key= keyResource x + mdbref <- unsafeIOToSTM $ mDBRefIO key + case mdbref of + Right dbref -> return dbref+ Left cache -> do + t <- unsafeIOToSTM timeInteger + tv <- newTVar DoNotExist+ let dbref= DBRef key tv+ (cache,_) <- unsafeIOToSTM $ readIORef refcache+ applyTriggers [dbref] [Just x]+ writeTVar tv . Exist $ Elem x t t + unsafeIOToSTM $ do+ w <- mkWeakPtr dbref . Just $ deleteFromCache dbref + H.update cache key ( CacheElem Nothing w) + return dbref ++-- | delete the content of the DBRef form the cache and from permanent storage+delDBRef :: (IResource a, Typeable a) => DBRef a -> STM()+delDBRef dbref@(DBRef k tv)= do+ mr <- readDBRef dbref+ case mr of+ Just x -> do+ safeIOToSTM $ delResource x+ applyTriggers [dbref] [Nothing]+ writeTVar tv DoNotExist+ Nothing -> return ()+ --withSTMResources [] $ const resources{toDelete=[x]}+ ++++ +-- | deletes the pointed object from the cache, not the database (see 'delDBRef')+-- useful for cache invalidation when the database is modified by other process +flushDBRef :: (IResource a, Typeable a) =>DBRef a -> STM()+flushDBRef (DBRef _ tv)= writeTVar tv NotRead+++-- | drops the entire cache.+flushAll :: STM ()+flushAll = do+ (cache,time) <- unsafeIOToSTM $ readIORef refcache+ elms <- unsafeIOToSTM $ toList cache+ mapM_ (del cache) elms+ where+ del cache ( _ , CacheElem _ w)= do+ mr <- unsafeIOToSTM $ deRefWeak w+ case mr of+ Just (DBRef _ tv) -> writeTVar tv DoNotExist+ Nothing -> unsafeIOToSTM (finalize w) ++ + +-- | This is the main function for the *Resource(s) calls. All the rest derive from it. The results are kept in the STM monad +-- so it can be part of a larger STM transaction involving other DBRefs +-- The 'Resources' register returned by the user-defined function is interpreted as such: +-- +-- * 'toAdd': the content of this field will be added/updated to the cache +-- +-- * 'toDelete': the content of this field will be removed from the cache and from permanent storage +-- +-- * 'toReturn': the content of this field will be returned by 'withSTMResources' +withSTMResources :: (IResource a, Typeable a)=> [a] -- ^ the list of resources to be retrieved + -> ([Maybe a]-> Resources a x) -- ^ The function that process the resources found and return a Resources structure + -> STM x -- ^ The return value in the STM monad. ++withSTMResources rs f= do + (cache,_) <- unsafeIOToSTM $ readIORef refcache + mtrs <- takeDBRefs rs cache AddToHash + + mrs <- mapM mreadDBRef mtrs + case f mrs of + Retry -> retry + Resources as ds r -> do+ safeIOToSTM $ mapM_ delResource ds+ applyTriggers (map (getDBRef . keyResource) as) (map Just as)+ applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing `asTypeOf` (Just(head ds))))+ delListFromHash cache ds + releaseTPVars as cache + return r + + where+ mreadDBRef :: (IResource a, Typeable a) => Maybe (DBRef a) -> STM (Maybe a) + mreadDBRef (Just dbref)= readDBRef dbref + mreadDBRef Nothing = return Nothing + + +-- | update of a single object in the cache +-- +-- @withResource r f= 'withResources' [r] (\[mr]-> [f mr])@ +withResource:: (IResource a, Typeable a) + => a -- ^ prototypes of the object to be retrieved for which keyResource can be derived + -> (Maybe a-> a) -- ^ update function that return another full object + -> IO () +withResource r f= withResources [r] (\[mr]-> [f mr]) + + +-- | to atomically add/modify many objects in the cache+ +-- @ withResources rs f= atomically $ 'withSTMResources' rs f1 >> return() where f1 mrs= let as= f mrs in Resources as [] ()@ +withResources:: (IResource a,Typeable a)=> [a]-> ([Maybe a]-> [a])-> IO () +withResources rs f= atomically $ withSTMResources rs f1 >> return() where + f1 mrs= let as= f mrs in Resources as [] () + +-- | to read a resource from the cache.+ +-- @getResource r= do{mr<- 'getResources' [r];return $! head mr}@ +getResource:: (IResource a, Typeable a)=>a-> IO (Maybe a) +getResource r= do{mr<- getResources [r];return $! head mr} + +--- | to read a list of resources from the cache if they exist+ +-- | @getResources rs= atomically $ 'withSTMResources' rs f1 where f1 mrs= Resources [] [] mrs@ +getResources:: (IResource a, Typeable a)=>[a]-> IO [Maybe a] +getResources rs= atomically $ withSTMResources rs f1 where + f1 mrs= Resources [] [] mrs + + +-- | delete the resource from cache and from persistent storage. +-- @ deleteResource r= 'deleteResources' [r] @ +deleteResource :: (IResource a, Typeable a) => a -> IO () +deleteResource r= deleteResources [r] + +-- | delete the list of resources from cache and from persistent storage.+ +-- @ deleteResources rs= atomically $ 'withSTMResources' rs f1 where f1 mrs = Resources [] (catMaybes mrs) ()@ +deleteResources :: (IResource a, Typeable a) => [a] -> IO () +deleteResources rs= atomically $ withSTMResources rs f1 where + f1 mrs = resources {toDelete=catMaybes mrs} + + +takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht -> CheckTPVarFlags -> STM [Maybe (DBRef a)] +takeDBRefs rs cache addToHash= mapM (takeDBRef cache addToHash) rs +++ +takeDBRef :: (IResource a, Typeable a) => Ht -> CheckTPVarFlags -> a -> STM(Maybe (DBRef a)) +takeDBRef cache flags x =do+ + let keyr= keyResource x + c <- unsafeIOToSTM $ H.lookup cache keyr + case c of + Just (CacheElem _ w) -> do+ mr <- unsafeIOToSTM $ deRefWeak w+ case mr of+ Just dbref -> return . Just $ castErr dbref+ Nothing -> unsafeIOToSTM (finalize w) >> takeDBRef cache flags x + Nothing -> do + safeIOToSTM $ readToCache flags cache keyr -- unsafeIOToSTM $ readResourceByKey keyr + + where+ readToCache flags cache key= do+ mr <- readResourceByKey key+ case mr of + Nothing -> return Nothing + Just r2 -> do + ti <- timeInteger + tvr <- newTVarIO . Exist $ Elem r2 ti ti + case flags of + NoAddToHash -> return . Just $ DBRef key tvr + AddToHash -> do+ let dbref= DBRef key tvr+ w <- mkWeakPtr dbref . Just $ deleteFromCache dbref + H.update cache key (CacheElem (Just dbref) w) + return $ Just dbref++ + + +timeInteger= do TOD t _ <- getClockTime + return t + + + + + +releaseTPVars :: (IResource a,Typeable a)=> [a] -> Ht -> STM () +releaseTPVars rs cache = mapM_ (releaseTPVar cache) rs + +releaseTPVar :: (IResource a,Typeable a)=> Ht -> a -> STM () +releaseTPVar cache r =do + c <- unsafeIOToSTM $ H.lookup cache keyr + case c of+ Just (CacheElem _ w) -> do+ mr <- unsafeIOToSTM $ deRefWeak w+ case mr of+ Nothing -> unsafeIOToSTM (finalize w) >> releaseTPVar cache r + Just (DBRef key tv) -> do+ t <- unsafeIOToSTM timeInteger + writeTVar tv . Exist $ Elem (castErr r) t t + + + Nothing -> do + ti <- unsafeIOToSTM timeInteger + tvr <- newTVar . Exist $ Elem r ti ti+ let dbref= DBRef keyr tvr+ w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ deleteFromCache dbref + unsafeIOToSTM $ H.update cache keyr (CacheElem (Just dbref) w)-- accesed and modified XXX + return () + + + where keyr= keyResource r + + + + +delListFromHash :: IResource a => Ht -> [a] -> STM () +delListFromHash cache xs= mapM_ del xs+ where+ del :: IResource a => a -> STM ()+ del x= do+ let key= keyResource x+ mr <- unsafeIOToSTM $ H.lookup cache key+ case mr of+ Nothing -> return ()+ Just (CacheElem _ w) -> do+ mr <- unsafeIOToSTM $ deRefWeak w+ case mr of+ Just (DBRef _ tv) -> writeTVar tv DoNotExist+ Nothing -> unsafeIOToSTM (finalize w) >> del x++ + +updateListToHash hash kv= mapM (update1 hash) kv where + update1 h (k,v)= update h k v + + + +-- | Start the thread that periodically call 'clearSyncCache' to clean and writes on the persistent storage. +-- Otherwise, 'syncCache' must be invoked explicitly or no persistence will exist.+-- Cache writes allways save a coherent state +clearSyncCacheProc :: + Int -- ^ number of seconds betwen checks. objects not written to disk are written + -> (Integer -> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example + -> Int -- ^ The max number of objects in the cache, if more, the cleanup starts + -> IO ThreadId -- ^ Identifier of the thread created +clearSyncCacheProc time check sizeObjects= forkIO clear + where + clear =handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do + threadDelay (fromIntegral$ time * 1000000) + clearSyncCache check sizeObjects --`debug` "CLEAR" + clear + + + +-- | Force the atomic write of all cached objects modified since the last save into permanent storage +-- Cache writes allways save a coherent state +syncCache :: IO () +syncCache = do+ (cache,lastSync) <- readIORef refcache+ t2<- timeInteger+ elems <- toList cache + (tosave,_,_) <- atomically $ extract elems lastSync + save tosave + writeIORef refcache (cache, t2) + + + +-- |Saves the unsaved elems of the cache+-- Cache writes allways save a coherent state +-- delete some elems of the cache when the number of elems > sizeObjects. +-- The deletion depends on the check criteria. 'defaultCheck' is the one implemented +clearSyncCache :: (Integer -> Integer-> Integer-> Bool)-> Int -> IO () +clearSyncCache check sizeObjects=do+ (cache,lastSync) <- readIORef refcache+ t <- timeInteger+ elems <- toList cache+ (tosave, elems, size) <- atomically $ extract elems lastSync + save tosave + when (size > sizeObjects) $ forkIO (filtercache t cache lastSync elems) >> performGC+ writeIORef refcache (cache, t)+ + where+ + -- delete elems from the cache according with the checking criteria + filtercache t cache lastSync elems= mapM_ filter elems+ where + filter (CacheElem Nothing w)= return() --alive because the dbref is being referenced elsewere+ filter (CacheElem (Just (DBRef key _)) w) = do+ mr <- deRefWeak w+ case mr of+ Nothing -> finalize w+ Just (DBRef _ tv) -> atomically $ do + r <- readTVar tv+ case r of+ Exist (Elem x lastAccess _ ) -> + if check t lastAccess lastSync+ then do+ unsafeIOToSTM . H.update cache key $ CacheElem Nothing w+ writeTVar tv NotRead+ else return ()+ _ -> return()++ + +-- | ths is a default cache clearance check. It forces to drop from the cache all the+-- elems not accesed since half the time between now and the last sync +-- if it returns True, the object will be discarded from the cache +-- it is invoked when the cache size exceeds the number of objects configured+-- in 'clearSyncCacheProc' or 'clearSyncCache' +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 +defaultCheck now lastAccess lastSync + | lastAccess > halftime = False + | otherwise = True + + where + halftime= now- (now-lastSync) `div` 2 ++refConditions= unsafePerformIO $ newIORef (return(), return()) ++setConditions :: IO() -> IO() -> IO()+-- ^ stablishes the procedures to call before and after saving with 'syncCache', 'clearSyncCache' or 'clearSyncCacheProc'. The postcondition of+-- database persistence should be a commit.+setConditions pre post= writeIORef refConditions (pre, post)++saving= unsafePerformIO $ newMVar False+ +save tosave = do+ takeMVar saving + (pre, post) <- readIORef refConditions + pre+ mapM (\(Filtered x) -> writeResource x) tosave + post+ putMVar saving False++data Filtered= forall a.(IResource a)=> Filtered a+++extract elems lastSave= filter1 [] [] (0::Int) elems+ where+ filter1 sav val n []= return (sav, val, n)+ filter1 sav val n ((_, ch@(CacheElem mybe w)):rest)= do+ mr <- unsafeIOToSTM $ deRefWeak w+ case mr of+ Nothing -> unsafeIOToSTM (finalize w) >> filter1 sav val n rest+ Just (DBRef key tvr) ->+ let tofilter = case mybe of+ Just _ -> ch:val+ Nothing -> val+ in do + r <- readTVar tvr+ case r of+ Exist (Elem r _ modTime) -> + if (modTime >= lastSave)+ then filter1 (Filtered r:sav) tofilter (n+1) rest+ else filter1 sav tofilter (n+1) rest ++ _ -> filter1 sav tofilter (n+1) rest +++ +safeIOToSTM :: IO a -> STM a+safeIOToSTM req= unsafeIOToSTM $ do+ tv <- newEmptyMVar+ forkIO $ req >>= putMVar tv+ takeMVar tv++++
− Data/TCache/Dynamic.hs
@@ -1,226 +0,0 @@-{-# OPTIONS -fglasgow-exts -XUndecidableInstances -XBangPatterns #-}--{- | Data.TCache.Dynamic:-A dynamic interface for TCache so that mixed datatypes can be managed participating in a single transaction.-The objects are encapsulated in a 'IDynamic' datatype, that is d Dynamic type that is serializable and indexable--Dynamic present essentially the same methods than Data.TCache. The added functionality is the management-of IDynamic types. Any datatype that is instance of IResource and Typeable can be handled mixed with any other-datatype. TCache.Dynamic is essentially a TCache working with a single datatype: IDynamic that is indexable and-serializable. You don´t need to do anything special except to define Typeable besides the IResource instance for-your particular datatype. Also, before use, your datatype must be registered (with 'registerType', see example in the package).--there are basically two types of methods in this module:-- * @with(STM)Resource(s)@ calls: manage one single type of data, in the same way than the naked @Data.TCache@ module, Are the same than Data.TCache.- The marsalling to and from IDynamic is managed internally. These calls do exactly the same than the TCache calls with the same name-these cals allows different modules to handle their particular kind of data without regard that it is being handled in the same cache with other datatypes.-- * @wthD(STM)Resource(s)@: are new, and handle the IDynamic type. The user must wrap your datatypes (with toIDyn) and unwap it (with fromIDyn)- These call permts to handle arbitrary types at the same time and partticipate in transactions.--There is also a useful 'Key' object whose purpose is to retrieve any objecto fo any datatype by its sting key--Also the parameter @refcache@ has been dropped from the methods that used it (the syncronization methods)--}--module Data.TCache.Dynamic(- T.IResource(..) -- from TCache- ,T.Resources(..)- ,T.resources- ,T.setCache- ,T.refcache- ,T.defaultCheck,T.readFileStrict- ,IDynamic(..) -- serializable/indexable existential datatype- ,T.Cache--- ,DynamicInterface (- toIDyn -- :: x -> IDynamic- ,registerType -- :: x- ,fromIDyn -- :: IDynamic -> x- ,unsafeFromIDyn -- :: IDynamic -> x- ,safeFromIDyn ---- :: IDynamic -> Maybe x- )- --,ofType- ,Key(..) {- Key datatype can be used to read any object trough the Dynamic interface-- let key= <key of the object >- mst <- getDResource $ Key (ofType :: Type) key- case mst of- Nothing -> error $ "getResource: not found "++ key- Just (idyn) -> do- let st = fromIDyn idyn :: <desired datatype>- ....- -}---- same access interface than TCache , this time for handling the Dynamic type. See Data.TCache for their equivalent definitions--- to use it you have to wrap (with toIDyn) and unwrap(with fromIDyn) your data in a IDynamic object-,getTVars, releaseTVars, getTVarsIO,withDResource, withDResources, withDSTMResources, getDResource, getDResources, deleteDResource, deleteDResources----- syncache has no parameters now (see Data.TCache.syncCache). -,syncCache---- Same than Data.TCache but without Cache parameter -,clearSyncCacheProc - --- the same interface for any datatype. wrapping and unwrapping are made internally.---have the same functionalities than the Data.TCache primitives with the same name. -, withResource, withResources, withSTMResources, getResource, getResources, deleteResource, deleteResources ---)--where--import System.IO.Unsafe-import Data.Typeable-import qualified Data.TCache as T-import Data.TCache.IDynamic as I-import Debug.Trace-import Control.Concurrent.STM(atomically,STM)-import Control.Concurrent.STM.TVar-import Control.Concurrent(forkIO)-import Control.Exception(finally)-import Data.TCache.IDynamic-import Control.Concurrent(ThreadId)-debug a b= trace b a---- | handles Dynamic objects using @Data.TCache.withResource@------ @withDResource = Data.TCache..withResource @ -withDResource :: IDynamic-> (Maybe IDynamic-> IDynamic)-> IO () -withDResource = T.withResource---- | @withDResources = Data.TCache.withResources@ -withDResources:: [IDynamic]-> ([Maybe IDynamic]-> [IDynamic])-> IO () -withDResources = T.withResources---- | this is the main function for the *Resource calls. All the rest derive from it. The results are kept in the STM monad--- so it can be part of a larger STM transaction involving other TVars--- The @Resources@ register returned by the user-defined function is interpreted as such:--- --- @toAdd@: additional resources not read in the first parameter of withSTMResources are created/updated with toAdd ------ @toDelete@: from the cache and from permanent storage--- --- @toReturn@: will be returned by withSTMResources -withDSTMResources- :: [IDynamic] -- ^ The list of resources to be retrieved- -> ([Maybe IDynamic] -> T.Resources IDynamic x) -- ^ The function that process the resources found and return a Resources structure- -> STM x -- ^ The return value in the STM monad. -withDSTMResources = T.withSTMResources---- | @getDResource = Data.TCache.getResource@ -getDResource :: IDynamic -> IO (Maybe IDynamic) -getDResource = T.getResource ---- | @getDResources = Data.TCache.getResources@ -getDResources :: [IDynamic] -> IO [Maybe IDynamic] -getDResources = T.getResources ---- | getTVars return the TVar that wraps the resources for which the keys are given . --- | it return @Nothing@ if a TVar with this object has not been allocated --- These TVars can be used as usual in explicit user constructed atomic blocks --- Additionally, the retrieved TVars remain in the cache and can be accessed and updated by the rest --- of the TCache methods. --- to keep the consistence in the serialized data, the content of the TVars are written every time the cache is syncronized with the storage until releaseTVars is called --- See 'Data.TCache.getTVars'-getTVars :: [IDynamic] -> STM [Maybe (TVar IDynamic)]-getTVars= T.getTVars--releaseTVars :: [IDynamic] -> STM ()-releaseTVars= T.releaseTVars--getTVarsIO :: [IDynamic] -> IO [TVar IDynamic]-getTVarsIO= T.getTVarsIO--- --- | retrieve a list of objects and return error if any resource is not found. instead of Nothing -justGetDResources rs=do mrs <- getDResources rs - return $ map process $ zip mrs rs - where - process (Nothing, r) = error ("\""++T.keyResource r ++ "\" does not exist") - process (Just r', _) = r' - -justGetDResource r= do [r']<- justGetDResources [r] - return r' - - --- | delete a resource from the cache and the storage -deleteDResource :: IDynamic -> IO () -deleteDResource= T.deleteResource ---- | delete a list of resources from the cache and the storage-deleteDResources :: [IDynamic] -> IO () -deleteDResources= T.deleteResources ---- syncronize the cache with the permanent storage-syncCache :: IO () -syncCache= T.syncCache (T.refcache :: T.Cache IDynamic) - --- | Start the thread that clean and writes on the persistent storage. --- Otherwise, syncCache must be invoked explicitly or no persistence will exist -clearSyncCacheProc- :: Int -- ^ number of seconds betwen checks. objects not written to disk are written- -> (Integer -> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example- -> Int -- ^ The max number of objects in the cache, if more, the cleanup starts- -> IO ThreadId -- ^ Identifier of the thread created -clearSyncCacheProc= T.clearSyncCacheProc (T.refcache :: T.Cache IDynamic) --{- | methods that handle a single datatype. -}---- | similar to @Data.TCache.withResource@.--- The fact that this method may return a type different that the source type permits to use ' Key' objects -withResource ::(Typeable a, Typeable b, T.IResource a, T.IResource b) => a-> (Maybe a-> b)-> IO () -withResource r f= withResources [r] (\[mr]-> [f mr])---- | similar to @Data.TCache.withResources@.--- The fact that this method may return a type different that the source type permits to use ' Key' objects -withResources::(Typeable a, Typeable b, T.IResource a, T.IResource b) => [a]-> ([Maybe a]-> [b])-> IO () -withResources rs f= withDResources (map toIDyn rs) (\mrs-> f' mrs) where- f' = map toIDyn . f . map g- g Nothing= Nothing- g (Just x)= Just (fromIDyn x)---- | similar to @Data.TCache.withSTMResources@.--- The return in the STM monad permits to participate in larger STM transactions--- The fact that this method may return a type different that the source type permits to use ' Key' objects -withSTMResources :: forall x.forall a.forall b.(Typeable a, Typeable b, T.IResource a, T.IResource b)- => [a] -- ^ the list of resources to be retrieved- -> ([Maybe a]-> T.Resources b x) -- ^ The function that process the resources found and return a Resources structure- -> STM x -- ^ The return value in the STM monad. -withSTMResources rs f= withDSTMResources (map toIDyn rs) f' where- f' :: [Maybe IDynamic]-> T.Resources IDynamic x- f' = h . f . map g-- g (Just x)= Just $ fromIDyn x- g Nothing = Nothing-- h T.Retry = T.Retry- h (T.Resources a d r)= T.Resources (map toIDyn a) (map toIDyn d) r---- | similar to Data.@TCache.getResource@.--- The fact that this method may return a type different that the source type permits to use ' Key' objects -getResource ::(Typeable a, Typeable b, T.IResource a, T.IResource b) => a -> IO (Maybe b) -getResource x= getDResource (toIDyn x) >>= return . g where - g Nothing= Nothing- g (Just x)= Just (fromIDyn x)---- | similar to @Data.TCache.getResources@.--- The fact that this method may return a type different that the source type permits to use ' Key' objects -getResources ::(Typeable a, Typeable b, T.IResource a, T.IResource b) => [a] -> IO [Maybe b] -getResources rs = getDResources (map toIDyn rs) >>= return . map g where - g Nothing= Nothing- g (Just x)= Just (fromIDyn x) - --- | similar to @Data.TCache.deleteResource@ -deleteResource ::(Typeable a, T.IResource a) => a -> IO () -deleteResource x= deleteDResource (toIDyn x) ---- | similar to @Data.TCache.deleteResource@ -deleteResources ::(Typeable a, T.IResource a) => [a] -> IO () -deleteResources xs= deleteDResources (map toIDyn xs) -
+ Data/TCache/FilePersistence.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+module Data.TCache.FilePersistence where+ ++import Data.TCache.IResource+++-- | Read, Show, instances are implicit instances of Serializable+instance (Show a, Read a) => Serializable a where+ serialize= show+ deserialize= read+++++-- | Serializable, Indexable instances are implicit instances of IResource+instance (Serializable a, Indexable a) => IResource a where+ keyResource =key+ readResourceByKey = defaultReadResourceByKey + writeResource = defaultWriteResource + delResource = defaultDelResource++
− Data/TCache/IDynamic.hs
@@ -1,159 +0,0 @@-{-# OPTIONS -fglasgow-exts -XUndecidableInstances -XBangPatterns #-}--{- |-IDynamic is a indexable and serializable version of Dynamic. (See @Data.Dynamic@). It is used as containers of objects-in the cache so any new datatype can be incrementally stored without recompilation.-IDimamic provices methods for safe casting, besides serializaton, deserialization, registrations and retrieval by lkey.--@data IDynamic= forall a. (Typeable a, IResource a) => IDynamic a deriving Typeable@--} -module Data.TCache.IDynamic where -import Data.Typeable -import Unsafe.Coerce -import System.IO.Unsafe -import Control.Concurrent.MVar -import Data.Map as M -import Data.TCache.IResource-import Data.RefSerialize -import Data.HashTable(hashString) -import Data.Word-import Numeric (showHex, readHex)-- -data IDynamic= forall a. (Typeable a, IResource a) => IDynamic a deriving Typeable - - -list :: MVar (Map Word (IDynamic -> IO (Maybe IDynamic), String -> IDynamic, ST IDynamic ) ) -list = unsafePerformIO $ newMVar $ empty --hash x= unsafeCoerce . hashString . show $ typeOf x :: Word -instance IResource IDynamic where - keyResource (IDynamic x)= keyResource x - serialize (IDynamic x)= "Dyn " ++ showHex (hash x) ( " " ++ serialize x) - deserialize str2=- let- str= drop 4 str2- [(t :: Word, str1)]= readHex str-- in- case M.lookup t (unsafePerformIO $ readMVar list) of - Nothing -> error $ "not registered type " ++ str1 ++ " please registerType it" - Just (_, f, _)-> f $ tail str1 -- tshowp (IDynamic x)= do- str <- tshowp x- return $ "Dyn " ++ showHex (hash x) ( " "++ str)-- treadp = do- symbol "Dyn"- t <- readHexp-- case M.lookup t (unsafePerformIO $ readMVar list) of - Nothing -> fail $ "not registered type please registerType it" - Just (_,_, f)-> f- <?> "IDynamic"- - defPath (IDynamic x)= defPath x - - writeResource (IDynamic x)= writeResource x - - readResource d@(IDynamic x) - | typeOfx== typeOf Key= do- mx <- readResource x --`debug` ("retrieving key "++ show (typeOf x)) - case mx of - Nothing -> return $ Nothing - Just x -> return $ Just $ toIDyn x - | otherwise= - case M.lookup type1 (unsafePerformIO $ readMVar list) of - Nothing -> error $ "not registered type " ++ show (typeOf x) ++ " please registerType it" - Just (f ,_,_)-> f d - where- typeOfx= typeOf x - type1= unsafeCoerce $ hashString $ show typeOfx :: Word - - -instance Show IDynamic where - show (IDynamic x)= "(IDynamic \""++show (typeOf x) ++"\" "++ serialize x++")" - - --- | DynamicInterface groups a set of default method calls to handle dynamic objects. It is not necessary to derive instances from it --class DynamicInterface x where- toIDyn :: x -> IDynamic -- ^ encapsulates data in a dynamic object - registerType :: IO x -- ^ registers the deserialize, readp and readResource methods for this data type - fromIDyn :: IDynamic -> x -- ^ extract the data from the dynamic object. trows a user error when the cast fails - unsafeFromIDyn :: IDynamic -> x -- ^ unsafe version. - safeFromIDyn :: IDynamic -> Maybe x -- ^ safe extraction with Maybe - -instance (IResource x,Typeable x) => DynamicInterface x where-- - toIDyn x= IDynamic x - - registerType = do - - let x= unsafeCoerce 1 :: x -- let deserializex str= toIDyn (deserialize str :: x)- let treadpx = do- t<- treadp :: ST x- return $ toIDyn t - let readResourcex (IDynamic s)= do - mr <- readResource (unsafeCoerce s :: x) :: IO (Maybe x) - case mr of - Nothing -> return Nothing - Just s' -> return $ Just $ IDynamic s' - l <- takeMVar list-- let key= hash x -- case M.lookup key l of - Just _ -> do - putMVar list l - return x - _ -> do - putMVar list $ insert key (readResourcex, deserializex, treadpx ) l - return x -- - - fromIDyn d@(IDynamic a)= if type2 == type1 then v - else error ("fromIDyn: casting "++ show type1 ++" to type "++show type2 ++" for data "++ serialize a) - where - v= unsafeCoerce a :: x - type1= typeOf a - type2= typeOf v - - unsafeFromIDyn (IDynamic a)= unsafeCoerce a -- safeFromIDyn (IDynamic a)= let v= unsafeCoerce a :: x in if typeOf a == typeOf v then Just v else Nothing- -{- | Key datatype can be used to read any object trough the Dynamic interface.- - @ data Key = Key 'TypeRep' String deriving Typeable @-- Example- - @ mst <- 'getDResource' $ 'Key' type 'keyofDesiredObject'- case mst of- Nothing -> error $ \"not found \"++ key- Just (idyn) -> fromIDyn idyn :: DesiredDatatype}@ --} - -data Key = Key TypeRep String deriving Typeable - - -instance IResource Key where - keyResource (Key _ k)=k - serialize _= error "Key is not serializable" - deserialize _= error "Key is not serializable" - writeResource _= error "Please don't create Key objects" - readResource key@(Key t _)= - case M.lookup type1 (unsafePerformIO $ readMVar list) of - Nothing -> error $ "not registered type "++show t++" please registerType it" - Just (f,_,_) -> do- d <- f . toIDyn $ key - return $ dynMaybe d - where - dynMaybe (Just dyn)= return $ fromIDyn dyn - type1= hash t
− Data/TCache/IResource.hs
@@ -1,190 +0,0 @@-module Data.TCache.IResource where - -import System.Directory -import Control.Exception as Exception -import System.IO.Error -import Data.List(elemIndices) -import System.IO -import Control.Monad(when,replicateM)-import qualified Data.RefSerialize as RS- ---import Debug.Trace----debug a b= trace b a - -{- | Interface that must be defined for every object being cached. - 'readResource' and 'writeResource' are implemented by default as read-write to files with its key as filename - 'serialize' and 'deserialize' are specified just to allow these defaults. If you define your own persistence, then- @serialize@ and @deserialize@ are not needed. The package 'Workflow' need them anyway. - -minimal definition: keyResource, serialize, deserialize--While serialize and deserialize are agnostic about the way of converison to strings, either binary or textual, treadp and-tshowp use the monad defined in the RefSerialize package. Both ways of serialization are alternative. one is defined-by default in terms of the other. the RefSerialize monad has been introduced to permit IResource objects to be-serialized as part of larger structures that embody them. This is necessary for the Workdlow package.- -The keyResource string must be a unique since this is used to index it in the hash table. -when accessing a resource, the user must provide a partial object for wich the key can be obtained. -for example:- -@data Person= Person{name, surname:: String, account :: Int ....) - -keyResource Person n s ...= n++s@ - -the data being accesed must have the fields used by keyResource filled. For example-- @ readResource Person {name="John", surname= "Adams"}@ - -leaving the rest of the fields undefined - --} ---- | IResource has defaults definitions for all the methods except keyResource--- Either one or other serializer must be defiened for default witeResource, readResource and delResource -class IResource a where -- keyResource :: a -> String -- ^ must be defined-- serialize :: a -> String -- ^ must be defined by the user- serialize x= RS.runW $ tshowp x- - deserialize :: String -> a -- ^ must be defined by the user- deserialize str = RS.runR treadp str - -- tshowp :: a -> RS.ST String -- ^ serializer in the 'RefSerialize' monad. Either one or other serializer must be defined to use default persistence- tshowp x= do- let str= serialize x- let l= length str- return $ show l ++ " " ++ str-- treadp :: RS.ST a -- ^ deserialize in the RefSerilzlize monad.- treadp = do- l <- RS.readp-- str <- replicateM l RS.anyChar- return $ deserialize str- - defPath :: a-> String -- ^ additional extension for default file paths or key prefixes - defPath _ = "" - - -- get object content from the file - -- (NOTE: reads and writes can't collide, so they-- Not really needed since no write is done while read - -- must be strict, not lazy ) - readResource :: a-> IO (Maybe a) - readResource x=handleJust Exception.ioErrors handle $ do - s <- readFileStrict filename :: IO String - return $ Just $ deserialize s -- `debug` ("read "++ filename) - where - filename= defPath x++ keyResource x - --handle :: IResource a => IOError -> IO (Maybe a) - handle e - |isAlreadyInUseError e = readResource x -- maybe is being written. try again. - - | isDoesNotExistError e = return Nothing - | isPermissionError e = error $ "readResource: no permissions for opening file: "++filename - | otherwise= error $ "readResource: " ++ show e - - writeResource:: a-> IO() - writeResource x= handleJust Exception.ioErrors (handle x) $ writeFile filename (serialize x) -- `debug` ("write "++filename) - where - filename= defPath x ++ keyResource x - --handle :: a -> IOError -> IO () - handle x e - | isDoesNotExistError e=do - createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename --maybe the path does not exist - writeResource x --- | isAlreadyInUseError e= writeResource x -- maybe is being read. try again - -- Not really needed since no write is done while read -- | otherwise =do- hPutStrLn stderr $ "writeResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" - writeResource x- {-- | isAlreadyExistsError e =- do- hPutStrLn stderr $ "writeResource: already exist file: " ++ filename ++ " retrying"- writeResource x---- | isAlreadyInUseError e =- do- hPutStrLn stderr $ "writeResource: already in use: " ++ filename ++ " retrying"- writeResource x- | isFullError e =- do- hPutStrLn stderr $ "writeResource: file full: " ++ filename ++ " retrying"- writeResource x- | isEOFError e =- do- hPutStrLn stderr $ "writeResource: EOF in file: " ++ filename ++ " retrying"- writeResource x- | isIllegalOperation e=- do- hPutStrLn stderr $ "writeResource: illegal Operation in file: " ++ filename ++ " retrying"- writeResource x- | isPermissionError e =- do- hPutStrLn stderr $ "writeResource:permission error in file: " ++ filename ++ " retrying"- writeResource x- | isUserError e =- do- hPutStrLn stderr $ "writeResource:user error in file: " ++ filename ++ " retrying"- writeResource x--- | otherwise =do- hPutStrLn stderr $ "writeResource: error " ++ show e ++ " in file: " ++ filename - writeResource x --} - - delResource:: a-> IO() - delResource x= handleJust Exception.ioErrors (handle filename) $ removeFile filename --`debug` ("delete "++filename)- - where- filename= defPath x ++ keyResource x - handle :: String -> IOError -> IO () - handle file e - | isDoesNotExistError e= return ()- | isAlreadyInUseError e= delResource x- | isPermissionError e= delResource x- - | otherwise = error ("delResource: " ++ show e ++ "for the file: "++ filename) - - - -type AccessTime = Integer -type ModifTime = Integer - - -infinite=10000000000 - --- | Resources returned by 'withSTMResources'' -data Resources a b- = Retry -- ^ forces a retry- | Resources - { toAdd :: [a] -- ^ resources to be inserted back in the cache- , toDelete :: [a] -- ^ resources to be deleted from the cache and from permanent storage - , toReturn :: b -- ^ result to be returned - }- ---- | @resources= Resources [] [] ()@-resources :: Resources a () -resources= Resources [] [] () - - - --- Strict file read, needed for the default file persistence -readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h- where- readIt h= do - s <- hFileSize h - let n= fromIntegral s - str <- replicateM n (hGetChar h) - return str - - -
+ Data/TCache/IndexQuery.hs view
@@ -0,0 +1,388 @@+{- | This module implements an experimental typed query language for TCache build on pure+haskell. It is minimally intrusive (no special data definitions, no special syntax, no template+haskell). It uses the same register fields from the data definitions. Both for both query conditions+ and selections. It is executed in haskell, no external database support is needed.++it includes++ - A method to trigger the 'index'-ation of values of the record fields that you want to query++ - A typed query language of these record fields, with++ * Relational operators: '.==.' '.>.' '.>=.' '.<=.' '.<.' '.&&.' '.||.' to compare fields with+ values(returning lists of DBRefs) or fields between them, returning joins (lists of pairs of+ lists of DBRefs that meet the condition).++ * a 'select' method to extract tuples of field values from the DBRefs++ * a 'recordsWith' clause to extract entire registers++An example that register the owner and name fields fo the Car register and the+name of the Person register, create the Bruce register, return the Bruce DBRef, create two Car registers with bruce as owner+and query for the registers with bruce as owner and its name alpabeticaly higuer than \"Bat mobile\"++@+import "Data.TCache"+import "Data.TCache.IndexQuery"+import "Data.TCache.FilePersistence"+import "Data.Typeable"++data Person= Person {pname :: String} deriving (Show, Read, Eq, Typeable)+data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)++instance 'Indexable' Person where key Person{pname= n} = \"Person \" ++ n+instance 'Indexable' Car where key Car{cname= n} = \"Car \" ++ n++main = do+ 'index' owner+ 'index' pname+ 'index' cname+ bruce <- atomically $ 'newDBRef' $ Person \"bruce\"+ atomically $ mapM_ 'newDBRef' [Car bruce \"Bat Mobile\", Car bruce \"Porsche\"]++ r \<- atomically $ 'select' (cname, owner) $ (owner '.==.' bruce) '.&&.' (cname '.>.' \"Bat Mobile\")++ print r+@++Will produce:++> [("Porsche",DBRef "Person bruce")]++NOTES:++* the index is instance of 'Indexable' and 'Serializable'. This can be used to+persist in the user-defined storoage. If "Data.TCache.FilePersistence" is included+the indexes will be written in files.++* The Join feature has not been properly tested++* Record fields are recognized by its type, so++> data Person = Person {name , surname :: String}++@name '.==.' "Bruce"@ is equual to @surname '.==.' "Bruce"@++Will return all the registers with surname "Bruce" as well. So if two or more+fields in a registers are to be indexed, they must have different types.++-}++{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses+, FunctionalDependencies, FlexibleInstances, UndecidableInstances+, TypeSynonymInstances, IncoherentInstances #-}+module Data.TCache.IndexQuery(index,RelationOps(..), recordsWith, (.&&.), (.||.), Select(..)) where++import Data.TCache+import Data.List+import Data.Typeable+import Control.Concurrent.STM+import Data.Maybe (catMaybes)+import qualified Data.Map as M+import Data.IORef+import qualified Data.Map as M+import System.IO.Unsafe++++newtype Index reg a= Index (M.Map a [DBRef reg]) deriving (Read, Show, Typeable)++keyIndex treg tv= "Index " ++ show treg ++ show tv++instance (Typeable reg, Typeable a) => Indexable (Index reg a) where+ key map= keyIndex typeofreg typeofa+ where+ [typeofreg, typeofa]= typeRepArgs $! typeOf map+++instance (IResource reg,Typeable reg, Ord a,Read reg, Read a, Show reg, Show a) => Serializable (Index reg a) where+ serialize= show+ deserialize= read++instance (Typeable reg, Typeable a, Read reg, Show reg+ , Read a, Show a, Ord a, IResource reg)+ => IResource (Index reg a) where+ keyResource = key+ writeResource s=do+ mf <- readIORef persistIndex+ case mf of Nothing -> defaultWriteResource s ; Just (PersistIndex _ f _) -> f $ serialize s++ readResourceByKey s= do+ mf <- readIORef persistIndex+ case mf of Nothing -> defaultReadResourceByKey s; Just (PersistIndex f _ _) -> f s >>= return . fmap deserialize++ delResource s= do+ mf <- readIORef persistIndex+ case mf of Nothing -> defaultDelResource s; Just (PersistIndex _ _ f) -> f$ keyResource s+++data PersistIndex= PersistIndex{+ readIndexByKey :: (String -> IO(Maybe String))+ , writeIndex :: (String -> IO())+ , deleteIndex :: (String -> IO())}++setPersistIndex :: PersistIndex -> IO ()+setPersistIndex p = writeIORef persistIndex $ Just p+++persistIndex :: IORef (Maybe PersistIndex)+persistIndex = unsafePerformIO $ newIORef Nothing+++++getIndex selector val= do+ let [one, two]= typeRepArgs $! typeOf selector+ let rindex= getDBRef $! keyIndex one two+ getIndexr rindex val+++getIndexr rindex val= do+ mindex <- readDBRef rindex++ let index = case mindex of Just (Index index) -> index; _ -> M.empty++ let dbrefs= case M.lookup val index of+ Just dbrefs -> dbrefs+ Nothing -> []++ return (rindex, Index index, dbrefs)+selectorIndex+ :: (Typeable reg,+ IResource reg,+ Typeable a,+ Read reg,+ Show reg,+ Read a,+ Show a,+ Ord a,+ Indexable reg) =>+ (reg -> a) -> DBRef (Index reg a) -> DBRef reg -> Maybe reg -> STM ()++selectorIndex selector rindex pobject mobj = do+ moldobj <- readDBRef pobject+ choice moldobj mobj+ where+ choice moldobj mobj=+ case (moldobj, mobj) of+ (Nothing, Nothing) -> return()+ (Just oldobj, Just obj) ->+ if selector oldobj==selector obj+ then return ()+ else do+ choice moldobj Nothing+ choice Nothing mobj++ (Just oldobj, Nothing) -> do -- delete the old selector value from the index+ let val= selector oldobj+ (rindex,Index index, dbrefs) <- getIndexr rindex val+ let dbrefs'= Data.List.delete pobject dbrefs+ writeDBRef rindex $ Index (M.insert val dbrefs' index)++ (Nothing, Just obj) -> do -- add the new value to the index+ let val= selector obj+ (rindex,Index index, dbrefs) <- getIndexr rindex val+ let dbrefs'= nub $ Data.List.insert pobject dbrefs+ writeDBRef rindex $ Index (M.insert val dbrefs' index)++{- | Register a trigger for indexing the values of the field passed as parameter.+ the indexed field can be used to perform relational-like searches+-}++index+ :: (Typeable reg,+ Typeable a,+ Read reg,+ Show reg,+ Read a,+ Show a,+ Ord a,+ IResource reg,+ Indexable reg) =>+ (reg -> a) -> IO ()+index sel=+ let [one, two]= typeRepArgs $! typeOf sel+ rindex= getDBRef $! keyIndex one two+ in addTrigger $ selectorIndex sel rindex++-- | implement the relational-like operators, operating on record fields+class RelationOps field1 field2 res | field1 field2 -> res where+ (.==.) :: field1 -> field2 -> STM res+ (.>.) :: field1 -> field2 -> STM res+ (.>=.):: field1 -> field2 -> STM res+ (.<=.) :: field1 -> field2 -> STM res+ (.<.) :: field1 -> field2 -> STM res++-- Instance of relations betweeen fields and values+-- field .op. valued+instance (Indexable reg,+ Typeable reg,+ Typeable a,+ Show reg,+ Ord a,+ Show a,+ Read a,+ IResource reg,+ Read reg) => RelationOps (reg -> a) a [DBRef reg] where+ (.==.) field value= do+ (_ ,_ ,dbrefs) <- getIndex field value+ return dbrefs++ (.>.) field value= retrieve field value (>)+ (.>=.) field value= retrieve field value (>=)+ (.<.) field value= retrieve field value (<)+ (.<=.) field value= retrieve field value (<=)+++join:: (Typeable rec,IResource rec, Typeable v, Typeable rec', IResource rec', Read v,+ Show v, Read rec, Show rec, Ord v, Read rec', Show rec')+ =>(v->v-> Bool) -> (rec -> v) -> (rec' -> v) -> STM[([DBRef rec], [DBRef rec'])]+join op field1 field2 =do+ idxs <- retrieveIndexes field1+ idxs' <- retrieveIndexes field2+ return $ mix idxs idxs'+ where+ opv (v, _ )(v', _)= v `op` v'+ mix xs ys=+ let zlist= [(x,y) | x <- xs , y <- ys, x `opv` y]+ in map ( \(( _, xs),(_ ,ys)) ->(xs,ys)) zlist++type JoinData reg reg'=[([DBRef reg],[DBRef reg'])]++-- Instance of relations betweeen fields+-- field1 .op. field2+instance (IResource reg,+ Typeable reg,+ IResource reg',+ Typeable reg',+ Typeable a,+ Ord a,+ Read a,+ Show a, Read reg, Show reg, Read reg', Show reg',+ Serializable a) =>RelationOps (reg -> a) (reg' -> a) (JoinData reg reg') where++ (.==.)= join (==)+ (.>.) = join (>)+ (.>=.)= join (>=)+ (.<=.)= join (<=)+ (.<.) = join (<)++class SetOperations set set' setResult | set set' -> setResult where+ (.||.) :: STM set -> STM set' -> STM setResult+ (.&&.) :: STM set -> STM set' -> STM setResult+++instance SetOperations [DBRef a] [DBRef a] [DBRef a] where+ (.&&.) fxs fys= do+ xs <- fxs+ ys <- fys+ return $ intersect xs ys++ (.||.) fxs fys= do+ xs <- fxs+ ys <- fys+ return $ union xs ys+++instance SetOperations (JoinData a a') [DBRef a] (JoinData a a') where+ (.&&.) fxs fys= do+ xss <- fxs+ ys <- fys+ return [(intersect xs ys, zs) | (xs,zs) <- xss]++ (.||.) fxs fys= do+ xss <- fxs+ ys <- fys+ return [(union xs ys, zs) | (xs,zs) <- xss]++instance SetOperations [DBRef a] (JoinData a a') (JoinData a a') where+ (.&&.) fxs fys= fys .&&. fxs+ (.||.) fxs fys= fys .||. fxs++instance SetOperations (JoinData a a') [DBRef a'] (JoinData a a') where+ (.&&.) fxs fys= do+ xss <- fxs+ ys <- fys+ return [(zs,intersect xs ys) | (zs,xs) <- xss]++ (.||.) fxs fys= do+ xss <- fxs+ ys <- fys+ return [(zs, union xs ys) | (zs,xs) <- xss]++retrieveIndexes :: (Typeable reg, Typeable a, Read a, Show a+ , Read reg, Show reg, Ord a, IResource reg)+ => (reg -> a) -> STM [(a,[DBRef reg])]+retrieveIndexes selector= do+ let [one, two]= typeRepArgs $! typeOf selector+ let rindex= getDBRef $! keyIndex one two+ mindex <- readDBRef rindex+ case mindex of Just (Index index) -> return $ M.toList index; _ -> return []++retrieve field value op= do+ index <- retrieveIndexes field+ let higuer = map (\(v, vals) -> if op v value then vals else []) index+ return $ concat higuer+++recordsWith+ :: (IResource a, Typeable a) =>+ STM [DBRef a] -> STM [ a]+recordsWith dbrefs= dbrefs >>= mapM readDBRef >>= return . catMaybes++++class Select selector a res | selector a -> res where+ select :: selector -> a -> res+++{-+instance (Select sel1 a res1, Select sel2 b res2 )+ => Select (sel1, sel2) (a , b) (res1, res2) where+ select (sel1,sel2) (x, y) = (select sel1 x, select sel2 y)+-}+++instance (Typeable reg, IResource reg) => Select (reg -> a) (STM [DBRef reg]) (STM [a]) where+ select sel xs= return . map sel =<< return . catMaybes =<< mapM readDBRef =<< xs+++instance (Typeable reg, IResource reg,+ Select (reg -> a) (STM [DBRef reg]) (STM [a]),+ Select (reg -> b) (STM [DBRef reg]) (STM [b]) )+ => Select ((reg -> a),(reg -> b)) (STM [DBRef reg]) (STM [(a,b)])+ where+ select (sel, sel') xs= mapM (\x -> return (sel x, sel' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs++instance (Typeable reg, IResource reg,+ Select (reg -> a) (STM [DBRef reg]) (STM [a]),+ Select (reg -> b) (STM [DBRef reg]) (STM [b]),+ Select (reg -> c) (STM [DBRef reg]) (STM [c]) )+ => Select ((reg -> a),(reg -> b),(reg -> c)) (STM [DBRef reg]) (STM [(a,b,c)])+ where+ select (sel, sel',sel'') xs= mapM (\x -> return (sel x, sel' x, sel'' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs+++instance (Typeable reg, IResource reg,+ Select (reg -> a) (STM [DBRef reg]) (STM [a]),+ Select (reg -> b) (STM [DBRef reg]) (STM [b]),+ Select (reg -> c) (STM [DBRef reg]) (STM [c]),+ Select (reg -> d) (STM [DBRef reg]) (STM [d]) )+ => Select ((reg -> a),(reg -> b),(reg -> c),(reg -> d)) (STM [DBRef reg]) (STM [(a,b,c,d)])+ where+ select (sel, sel',sel'',sel''') xs= mapM (\x -> return (sel x, sel' x, sel'' x, sel''' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs++-- for join's (field1 op field2)++instance (Typeable reg, IResource reg,+ Typeable reg', IResource reg',+ Select (reg -> a) (STM [DBRef reg]) (STM [a]),+ Select (reg' -> b) (STM [DBRef reg']) (STM [b]) )+ => Select ((reg -> a),(reg' -> b)) (STM (JoinData reg reg')) (STM [([a],[b])])+ where+ select (sel, sel') xss = xss >>= mapM select1+ where+ select1 (xs, ys) = do+ rxs <- return . map sel =<< return . catMaybes =<< mapM readDBRef xs+ rys <- return . map sel' =<< return . catMaybes =<< mapM readDBRef ys+ return (rxs,rys)
− Data/TCache/TMVar.hs
@@ -1,378 +0,0 @@-{-# OPTIONS -fglasgow-exts -XUndecidableInstances #-} - - -{- | A version of @Data.TCache@ using @TMVar@s instead of @TVars@s. See @Control.Concurrent.TMVar@--} - -module Data.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 - - -) -where - -import GHC.Conc -import Control.Concurrent.STM.TMVar-import Control.Monad(when) -import Data.HashTable as H -import Data.IORef -import System.IO.Unsafe-import System.Time -import Data.Maybe(catMaybes,mapMaybe) -import Debug.Trace -import Data.TCache.IResource -import Control.Exception(handle,assert) -import Data.List (nubBy,deleteFirstsBy ) - -debug a b= trace b a - -type Block a= (TMVar a,AccessTime,ModifTime) -type Ht a= HashTable String (Block a) --- contains the hastable, number of items, last sync time -type Cache a= IORef (Ht a, Integer) -data CheckBlockFlags= AddToHash | NoAddToHash | MaxTime - --- |set the cache. this is useful for hot loaded modules that will update an existing cache -setCache :: (Ht a, Integer) -> IO() -setCache ch= writeIORef refcache ch - --- the cache holder. stablished by default -refcache :: Cache a -refcache =unsafePerformIO $do - c <- newCache - newIORef c - --- | newCache creates a new cache -newCache :: IO (Ht a, Integer) -newCache =do - c <- H.new (==) hashString - return (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 :: (IResource a)=> [a] -> STM [Maybe (TMVar a)]-getTMVars rs= do- (cache,_) <- unsafeIOToSTM $ readIORef refcache - takeBlocks rs cache MaxTime - --- | 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 :: (IResource a)=> [a]-> STM () -releaseTMVars rs=do - (cache,_) <- unsafeIOToSTM $ readIORef refcache - releaseBlocks rs cache - --- | 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 called -getTMVarsIO :: (IResource a)=> [a] -> IO [TMVar a] -getTMVarsIO rs= do - tvs<- mapM newTMVarIO rs - (cache,_) <- readIORef refcache - mapM_ (\(tv,r)-> H.update cache (keyResource r) (tv, infinite, infinite)) $ zip tvs rs - return tvs - - - --- | 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 call - - -withSTMResources :: (IResource a)=> [a] -- ^ the list of resources to be retrieved - -> ([Maybe a]-> Resources a x) -- ^ The function that process the resources found and return a Resources structure - -> STM x -- ^ The return value in the STM monad. -withSTMResources rs f= do - (cache,_) <- unsafeIOToSTM $ readIORef refcache - mtrs <- takeBlocks rs cache NoAddToHash - - mrs <- mapM mreadTMVar mtrs - case f mrs of- Retry -> retry- Resources as ds r -> do - unsafeIOToSTM $ do- delListFromHash cache $ map keyResource ds - mapM delResource ds - releaseBlocks as cache - return r - - where - - - - mreadTMVar (Just tvar)= do r <- takeTMVar tvar - return $ Just r - mreadTMVar Nothing = return Nothing - - --- | update of a single object in the cache --- :: (IResource a)=> a same as withResources , but for one only object --- -> ([Maybe a]-> a) --- -> IO () -withResource:: (IResource a)=> a-> (Maybe a-> a)-> IO () -withResource r f= withResources [r] (\[mr]-> [f mr]) ----- | 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:: (IResource a)=> [a]-> ([Maybe a]-> [a])-> IO () -withResources rs f= atomically $ withSTMResources rs f1 >> return() where - f1 mrs= let as= f mrs in Resources as [] ()- --- | to read a resource from the cache -getResource r= do{mr<- getResources [r];return $! head mr} - ----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 result - -getResources:: (IResource a)=>[a]-> IO [Maybe a] -getResources rs= atomically $ withSTMResources rs f1 where - f1 mrs= Resources [] [] mrs - - --- | delete the resource from cache and from persistent storage - -deleteResource r= deleteResources [r] - --- | delete the list of resources from cache and from persistent storage - -deleteResources rs= atomically $ withSTMResources rs f1 where - f1 mrs = Resources [] (catMaybes mrs) () - - --takeBlocks :: (IResource a)=> [a] -> Ht a -> CheckBlockFlags -> STM [Maybe (TMVar a)]-takeBlocks rs cache addToHash= mapM (checkBlock cache addToHash) rs - where- checkBlock :: IResource a => Ht a -> CheckBlockFlags -> a-> STM(Maybe (TMVar a)) - checkBlock cache flags r =do - c <- unsafeIOToSTM $ H.lookup cache keyr - case c of - Nothing -> do - mr <- unsafeIOToSTM $ readResource r -- `debug` ("read "++keyr++ " hash= "++ (show $ H.hashString keyr)) - case mr of - Nothing -> return Nothing - Just r2 -> do - tvr <- newTMVar r2 - case flags of - NoAddToHash -> return $ Just tvr - AddToHash -> do - ti <- unsafeIOToSTM timeInteger - unsafeIOToSTM $ H.update cache keyr (tvr, ti, 0) -- accesed, not modified - return $ Just tvr - - MaxTime -> do - unsafeIOToSTM $ H.update cache keyr (tvr, infinite, infinite) -- accesed, not modified - return $ Just tvr-- - - Just(tvr,_,_) -> return $ Just tvr - - where keyr= keyResource r -- -releaseBlocks :: (IResource a)=> [a] -> Ht a -> STM ()-releaseBlocks rs cache = mapM_ checkBlock rs - - where - checkBlock r =do - c <- unsafeIOToSTM $ H.lookup cache keyr - case c of - Nothing -> do tvr <- newTMVar r - ti <- unsafeIOToSTM timeInteger - unsafeIOToSTM $ H.update cache keyr (tvr, ti, ti ) -- accesed and modified XXX - - - Just(tvr,_,tm) -> do - ti <- unsafeIOToSTM timeInteger - let t= max ti tm - try<- tryPutTMVar tvr r --putTMVar tvr r - case try of - False -> do swapTMVar tvr r; return () - True -> return () - unsafeIOToSTM $ H.update cache keyr (tvr ,t,t) - - - - where keyr= keyResource r - - -timeInteger= do TOD t _ <- getClockTime - return t - - - -delListFromHash hash l= do{mapM (delete hash) l; return()} - -updateListToHash hash kv= do{mapM (update1 hash) kv; return()}where - update1 h (k,v)= update h k v - ------------------------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 created - -clearSyncCacheProc :: (IResource a)=> Cache a-> Int-> (Integer -> Integer-> Integer-> Bool)-> Int-> IO ThreadId -clearSyncCacheProc refcache time check sizeObjects= - forkIO clear - - where- clear = do - threadDelay $ (fromIntegral$ time * 1000000) - clearSyncCache refcache time check sizeObjects - clear - --- | force the atomic write of all the cached objects into permanent storage --- useful for termination -syncCache refcache = do - (cache,t1) <- readIORef refcache - list <- toList cache - t2<- timeInteger - atomically $ save list t1 - writeIORef refcache (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 implemented -clearSyncCache ::(IResource a) => Cache a-> Int -> (Integer -> Integer-> Integer-> Bool)-> Int -> IO () -clearSyncCache refcache time check sizeObjects=do - (cache,lastSync) <- readIORef refcache - handle (\e-> do{print e;return ()})$ do - elems <- toList cache - let size=length elems - atomically $ save elems lastSync - t<- timeInteger - when (size > sizeObjects) (filtercache t cache lastSync elems) - writeIORef refcache (cache, t) - - where - -- delete elems from the cache according with the check criteria - filtercache t cache lastSync elems= mapM_ filter elems - where - check1 (_,lastAccess,_)=check t lastAccess lastSync - - filter ::(String,Block a)-> IO Int - filter (k,e)= if check1 e then do{H.delete cache k;return 1} else return 0 - --- | 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 sync - -defaultCheck:: Integer -> Integer-> Integer-> Bool -defaultCheck now lastAccess lastSync - | lastAccess > halftime = False - | otherwise = True - - where - halftime= now- (now-lastSync) `div` 2 - - - -save:: (IResource a) => [(String, Block a)]-> Integer-> STM () -save list lastSave= mapM_ save1 list --`debug` ("saving "++ (show $ length list)) - where- save1 :: IResource a =>(String, Block a) -> STM() - save1(_, (tvr,_,modTime))= do - if modTime >= lastSave --`debug` ("modTime="++show modTime++"lastSave="++show lastSave) - then do - r<- readTMVar tvr - unsafeIOToSTM $! writeResource r --`debug` ("saved " ++ keyResource r) - else return() - - - -
− Data/TCache/TMVar/Dynamic.hs
@@ -1,183 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--{- | Data.TCache.TMVar.Dynamic:-A dynamic interface for TCache using TMVars--Dynamic present essentially the same methods than Data.TCache. The added functionality is the management-of IDynamic types. Any datatype that is instance of IResource and Typeable can be handled mixed with any other-datatype. TCache.Dynamic is essentially a TCache working with a single datatype: IDynamic that is indexable and-serializable. You don´t need to do anything special except to define the IResource and typeable instances for-your particular datatype. Also, before use, your datatype must be registered (with registerType, see example in the package).--there are basically two types of methods:-- **Resource(s) : manage one type of data, Are the same than Data.TCache. The marsalling to and from IDynamic is managed internally-- **DResource(s): handle the IDynamic type. you must wrap your datatype (with toIDyn) and unwap it (with fromIDyn)--The first set allows different modules to handle their particular kind of data without regard that it is being handled in the same cache with other datatypes.--The second set allows to handle, transact etc with many datatypes at the same time.--There is also a useful Key object whose purpose is to retrieve any objecto fo any datatype by its sting key--Also the parameter refcache has been dropped from the methods that used it (the syncronization methods)---}--module Data.TCache.TMVar.Dynamic(- T.IResource(..) -- from TCache- ,T.Resources(..)- ,T.resources- ,T.setCache- ,T.refcache- ,T.defaultCheck,T.readFileStrict- ,I.IDynamic(..) -- serializable/indexable existential datatype- ,T.Cache--- ,DynamicInterface (- toIDyn -- :: x -> IDynamic- ,registerType -- :: x- ,fromIDyn -- :: IDynamic -> x- ,unsafeFromIDyn -- :: IDynamic -> x-- )- --,ofType- ,I.Key(..) {- Key datatype can be used to read any object trough the Dynamic interface-- let key= <key of the object >- mst <- getDResource $ Key (ofType :: Type) key- case mst of- Nothing -> error $ "getResource: not found "++ key- Just (idyn) -> do- let st = fromIDyn idyn :: <desired datatype>- ....- -}---- same access interface , this time for Dynamic type. See Data.TCache for their equivalent definitions-,getTMVars,getTMVarsIO,withDResource, withDResources, withDSTMResources, getDResource, getDResources, deleteDResource, deleteDResources----- syncache has no parameters now (see Data.TCache.syncCache) -,syncCache---- Same than Data.TCache but without Cache parameter -,clearSyncCacheProc - --- the same interface for any datatype: -, withResource, withResources, withSTMResources, getResource, getResources, deleteResource, deleteResources ---)--where--import System.IO.Unsafe-import Data.Typeable-import qualified Data.TCache.TMVar as T-import Data.TCache.IDynamic as I-import Debug.Trace-import Control.Concurrent.STM(atomically,STM)-import Control.Concurrent.STM.TMVar-import Control.Concurrent(forkIO)-import Control.Exception(finally)---debug a b= trace b a--- -withDResource :: IDynamic->(Maybe IDynamic->IDynamic)->IO () -withDResource = T.withResource- -withDResources:: [IDynamic]->([Maybe IDynamic]->[IDynamic])->IO () -withDResources = T.withResources-- -withDSTMResources :: [IDynamic]->([Maybe IDynamic]->T.Resources IDynamic x)->STM x -withDSTMResources = T.withSTMResources- -getDResource :: IDynamic -> IO (Maybe IDynamic) -getDResource = T.getResource - -getDResources :: [IDynamic] -> IO [Maybe IDynamic] -getDResources = T.getResources --getTMVars :: [IDynamic] -> STM [Maybe (TMVar IDynamic)]-getTMVars= T.getTMVars--getTMVarsIO :: [IDynamic] -> IO [TMVar IDynamic]-getTMVarsIO= T.getTMVarsIO--- --- | return error if any resource is not found -justGetDResources rs=do mrs <- getDResources rs - return $ map process $ zip mrs rs - where - process (Nothing, r) = error ("\""++T.keyResource r ++ "\" does not exist") - process (Just r', _) = r' - -justGetDResource r= do [r']<- justGetDResources [r] - return r' - - - -deleteDResource :: IDynamic -> IO () -deleteDResource= T.deleteResource --deleteDResources :: [IDynamic] -> IO () -deleteDResources= T.deleteResources - -syncCache= T.syncCache (T.refcache :: T.Cache IDynamic) - - - -clearSyncCacheProc= T.clearSyncCacheProc (T.refcache :: T.Cache IDynamic) - -withResource ::(Typeable a, Typeable b, T.IResource a, T.IResource b) => a->(Maybe a->b)->IO () -withResource r f= withResources [r] (\[mr]-> [f mr])- -withResources::(Typeable a, Typeable b, T.IResource a, T.IResource b) => [a]->([Maybe a]->[b])->IO () -withResources rs f= withDResources (map toIDyn rs) (\mrs-> f' mrs) where- f' = map toIDyn . f . map g- g Nothing= Nothing- g (Just x)= Just (fromIDyn x)-- -withSTMResources :: forall x.forall a.forall b.(Typeable a, Typeable b, T.IResource a, T.IResource b) => [a] -- ^ the list of resources to be retrieved- ->([Maybe a]-> T.Resources b x) -- ^ The function that process the resources found and return a Resources structure- -> STM x -- ^ The return value in the STM monad. -withSTMResources rs f= withDSTMResources (map toIDyn rs) f' where- f' :: [Maybe IDynamic]-> T.Resources IDynamic x- f' = h . f . map g-- g (Just x)= Just $ fromIDyn x- g Nothing = Nothing--- maybeDyn ( Just x) = Just $ toIDyn x- maybeDyn Nothing = Nothing-- h (T.Resources a d r)= T.Resources (map toIDyn a) (map toIDyn d) r-- -getResource ::(Typeable a, Typeable b, T.IResource a, T.IResource b) => a -> IO (Maybe b) -getResource x= getDResource (toIDyn x) >>= return . g where - g Nothing= Nothing- g (Just x)= Just (fromIDyn x)- -getResources ::(Typeable a, Typeable b, T.IResource a, T.IResource b) => [a] -> IO [Maybe b] -getResources rs = getDResources (map toIDyn rs) >>= return . map g where - g Nothing= Nothing- g (Just x)= Just (fromIDyn x) - - - -deleteResource ::(Typeable a, T.IResource a) => a -> IO () -deleteResource x= deleteDResource (toIDyn x) - -deleteResources ::(Typeable a, T.IResource a) => [a] -> IO () -deleteResources xs= deleteDResources (map toIDyn xs) -
TCache.cabal view
@@ -1,57 +1,51 @@ name: TCache-version: 0.6.5-synopsis: A Transactional data cache with configurable persistence+version: 0.8.0+synopsis: Data caching and Persistent STM transactions description:- Data.Tcache is a transactional cache with configurable persistence. It tries to simulate Hibernate- for Java or Rails for Ruby. The main difference is that transactions are done in memory trough STM.- There are transactional cache implementations for some J2EE servers like JBOSS.- .- TCache uses STM. It can atomically apply a function to a list of cached objects. The resulting- objects go back to the cache (withResources). It also can retrieve these objects (getResources).- Persistence can be syncronous (syncCache) or asyncronous, wtih configurable time between cache- writes and configurable cache clearance strategy. the size of the cache can be configured too .- All of this can be done trough clearSyncCacheProc. Even the TVar variables can be accessed- directly (getTVar) to acceess all the semantic of atomic blocks while maintaining the persistence of the- TVar updates.- .- Persistence can be defined for each object: Each object must have a defined key, a default filename- path (if applicable). Persistence is pre-defined in files, but the readResource writeResource and- delResource methods can be redefined to persist in databases or whatever.- .- Serialization is also configurable.- .- There are Samples here that explain the main features.- . - In this release+ TCache is a transactional cache with configurable persitence. It allows conventional+ STM transactions for objects that syncronize with+ their user defined storages. Default persistence in files is provided for testing purposes .- * added withSTMResources. Most of the rest of the methods are derived from withSTMResources . the results are returned in the STM monad, so this method can be part of al larger STM transaction- It also can perforn used defined retries.+ This version support the backward compatible stuff, that permits transparent+ retrievals of objects and transcactions between objects without directly using STM references+ ('with*Resource(s)' calls), Now it goes in the oposite direction by providing explicit STM persistent+ references (called 'DBRefś') that leverage the nice and traditional haskell reference syntax+ for performing database transactions. .- * added modules for cached TMVars- Data.TCache.TMVar and Data.TCache.TMVar.Dynamic uses TMVars instead of TVars (See Control.Concurrent.STM.TMVar)+ 'DBRef's are in essence, persistent TVars indexed in the cache, with a traditional 'readDBRef',+ 'writeDBRef' Haskell interface in the STM monad.+ Additionally, because DBRefs are serializable, they can be embeded in serializable registers.+ Because they are references,they point to other serializable registers.+ This permits persistent mutable and efficient Inter-object relations. .- It is not possible tu mix TVars and TMVars packages in the same executable. However code that uses dynamic and non dynamic can- can be mixed- .- * Data.TCache - cached TVars of object of type a.- .- * Data.TCache.Dynamic - cached TVars of objects of type IDynamic.- .- * Data.TCache.TMVar - cached TMVars of objects of type a.- .- * Data.TCache..TMVar.Dynamic - cached TMVars of objects of type IDynamic.+ Triggers are also included in this release. They are user defined hooks that are called back on register updates. That can be used for+ easing the actualization of inter-object relations and also permit more higuer level+ and customizable accesses. The internal indexes used for the query language uses triggers. + .+ It also implements an straighforwards non-intrusive pure-haskell type safe query language based+ on register field relations. This module must be imported separately. See+ "Data.TCache.IndexQuery" for further information+ .+ Now the file persistence is more reliable.The IO reads are safe inside STM transactions.+ .+ To ease the implementation of other user-defined persistence, "Data.TCache.FIlePersistence" needed+ to be imported explcitly for deriving file persistence instances.+ .+ In this release some stuff has been supressed without losing functionality. Dynamic interfaces+ are not needed since TCache can handle heterogeneous data. -category: Middleware, Data, Database, Concurrency++category: Data, Database, Concurrency license: BSD3 license-file: LICENSE author: Alberto Gómez Corona maintainer: agocorona@gmail.com-Tested-With: GHC == 6.8.2+Tested-With: GHC == 6.12.3 Build-Type: Simple-build-Depends: base >=3 && <4,directory >= 1.0, old-time >=1.0,stm>=2, containers>=0.1.0.1, RefSerialize >= 0.2.4-Cabal-Version: >= 1.2+build-Depends: base >=4 && <5,directory >= 1.0, old-time >=1.0,stm>=2, containers >= 0.1.0.1, transformers >=0.2 && <0.3 -exposed-modules: Data.TCache, Data.TCache.IResource, Data.TCache.Dynamic, Data.TCache.TMVar, Data.TCache.TMVar.Dynamic, Data.TCache.IDynamic++exposed-modules: Data.TCache, Data.TCache.FilePersistence, Data.TCache.IndexQuery ghc-options: -O2