diff --git a/Data/TCache.hs b/Data/TCache.hs --- a/Data/TCache.hs +++ b/Data/TCache.hs @@ -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 + + + + diff --git a/Data/TCache/Dynamic.hs b/Data/TCache/Dynamic.hs deleted file mode 100644 --- a/Data/TCache/Dynamic.hs +++ /dev/null @@ -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= - mst <- getDResource $ Key (ofType :: Type) key - case mst of - Nothing -> error $ "getResource: not found "++ key - Just (idyn) -> do - let st = fromIDyn idyn :: - .... - -} - --- 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) - diff --git a/Data/TCache/FilePersistence.hs b/Data/TCache/FilePersistence.hs new file mode 100644 --- /dev/null +++ b/Data/TCache/FilePersistence.hs @@ -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 + + diff --git a/Data/TCache/IDynamic.hs b/Data/TCache/IDynamic.hs deleted file mode 100644 --- a/Data/TCache/IDynamic.hs +++ /dev/null @@ -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 diff --git a/Data/TCache/IResource.hs b/Data/TCache/IResource.hs deleted file mode 100644 --- a/Data/TCache/IResource.hs +++ /dev/null @@ -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 - - - diff --git a/Data/TCache/IndexQuery.hs b/Data/TCache/IndexQuery.hs new file mode 100644 --- /dev/null +++ b/Data/TCache/IndexQuery.hs @@ -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) diff --git a/Data/TCache/TMVar.hs b/Data/TCache/TMVar.hs deleted file mode 100644 --- a/Data/TCache/TMVar.hs +++ /dev/null @@ -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() - - - - diff --git a/Data/TCache/TMVar/Dynamic.hs b/Data/TCache/TMVar/Dynamic.hs deleted file mode 100644 --- a/Data/TCache/TMVar/Dynamic.hs +++ /dev/null @@ -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= - mst <- getDResource $ Key (ofType :: Type) key - case mst of - Nothing -> error $ "getResource: not found "++ key - Just (idyn) -> do - let st = fromIDyn idyn :: - .... - -} - --- 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) - diff --git a/TCache.cabal b/TCache.cabal --- a/TCache.cabal +++ b/TCache.cabal @@ -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