diff --git a/Data/Persistent/Collection.hs b/Data/Persistent/Collection.hs --- a/Data/Persistent/Collection.hs +++ b/Data/Persistent/Collection.hs @@ -1,250 +1,250 @@ -{-# OPTIONS -XDeriveDataTypeable - -XTypeSynonymInstances - -XMultiParamTypeClasses - -XExistentialQuantification - -XOverloadedStrings - -XFlexibleInstances - -XUndecidableInstances - -XFunctionalDependencies - - #-} - -{- | -A persistent, transactional collection with Queue interface as well as - indexed access by key. - - Uses default persistence. See "Data.TCache.DefaultPersistence" - --} -{- -NOTES -TODO: -data.persistent collection - convertirlo en un tree - añadiendo elementos node Node (refQueue a) - implementar un query language - by key - by attribute (addAttibute) - by class - xpath - implementar un btree sobre el --} -module Data.Persistent.Collection ( -RefQueue(..), getQRef, -pop,popSTM,pick, flush, flushSTM, -pickAll, pickAllSTM, push,pushSTM, -pickElem, pickElemSTM, readAll, readAllSTM, -deleteElem, deleteElemSTM,updateElem,updateElemSTM, -unreadSTM,isEmpty,isEmptySTM -) where -import Data.Typeable -import Control.Concurrent.STM(STM,atomically, retry) -import Control.Monad -import Data.TCache.DefaultPersistence - -import Data.TCache -import System.IO.Unsafe -import Data.RefSerialize -import Data.ByteString.Lazy.Char8 -import Data.RefSerialize - -import Debug.Trace - -a !> b= trace b a - - - - -instance Indexable (Queue a) where - key (Queue k _ _)= queuePrefix ++ k - - - - -data Queue a= Queue {name :: String, imp :: [a], out :: [a]} deriving (Typeable) - - - -instance Serialize a => Serialize (Queue a) where - showp (Queue n i o)= showp n >> showp i >> showp o - readp = return Queue `ap` readp `ap` readp `ap` readp --- do --- n <- readp --- i <- readp --- o <- readp --- return $ Queue n i o - - - - -queuePrefix= "Queue#" -lenQPrefix= Prelude.length queuePrefix - - - -instance Serialize a => Serializable (Queue a ) where - serialize = runW . showp - deserialize = runR readp - --- | A queue reference -type RefQueue a= DBRef (Queue a) - --- | push an element at the top of the queue -unreadSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () -unreadSTM queue x= do - r <- readQRef queue - writeDBRef queue $ doit r - where - doit (Queue n imp out) = Queue n imp ( x : out) - - --- | Check if the queue is empty -isEmpty :: (Typeable a, Serialize a) => RefQueue a -> IO Bool -isEmpty = atomically . isEmptySTM - -isEmptySTM :: (Typeable a, Serialize a) => RefQueue a -> STM Bool -isEmptySTM queue= do - r <- readDBRef queue - return $ case r of - Nothing -> True - Just (Queue _ [] []) -> True - _ -> False - - - --- | Get the reference to new or existing queue trough its name -getQRef :: (Typeable a, Serialize a) => String -> RefQueue a -getQRef n = getDBRef . key $ Queue n undefined undefined - - --- | Empty the queue (factually, it is deleted) -flush :: (Typeable a, Serialize a) => RefQueue a -> IO () -flush = atomically . flushSTM - --- | Version in the STM monad -flushSTM :: (Typeable a, Serialize a) => RefQueue a -> STM () -flushSTM tv= delDBRef tv - --- | Read the first element in the queue and delete it (pop) -pop - :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name - -> IO a -- ^ the returned elems -pop tv = atomically $ popSTM tv - - -readQRef :: (Typeable a, Serialize a) => RefQueue a -> STM(Queue a) -readQRef tv= do - mdx <- readDBRef tv - case mdx of - Nothing -> do - let q= Queue ( Prelude.drop lenQPrefix $ keyObjDBRef tv) [] [] - writeDBRef tv q - return q - Just dx -> - return dx - --- | Version in the STM monad -popSTM :: (Typeable a, Serialize a) => RefQueue a - -> STM a -popSTM tv=do - dx <- readQRef tv - doit dx - - where - - doit (Queue n [x] [])= do - writeDBRef tv $ (Queue n [] []) - return x - doit (Queue _ [] []) = retry - doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) - doit (Queue n imp list ) = do - writeDBRef tv (Queue n imp (Prelude.tail list )) - return $ Prelude.head list - --- | Read the first element in the queue but it does not delete it -pick - :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name - -> IO a -- ^ the returned elems -pick tv = atomically $ do - dx <- readQRef tv - doit dx - where - doit (Queue _ [x] [])= return x - doit (Queue _ [] []) = retry - doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) - doit (Queue n imp list ) = return $ Prelude.head list - --- | Push an element in the queue -push :: (Typeable a, Serialize a) => RefQueue a -> a -> IO () -push tv v = atomically $ pushSTM tv v - --- | Version in the STM monad -pushSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () -pushSTM tv v= - readQRef tv >>= \ ((Queue n imp out)) -> writeDBRef tv $ Queue n (v : imp) out - --- | Return the list of all elements in the queue. The queue remains unchanged -pickAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] -pickAll= atomically . pickAllSTM - --- | Version in the STM monad -pickAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] -pickAllSTM tv= do - (Queue name imp out) <- readQRef tv - return $ out ++ Prelude.reverse imp - --- | Return the first element in the queue that has the given key -pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a) -pickElem tv key= atomically $ pickElemSTM tv key - --- | Version in the STM monad -pickElemSTM :: (Indexable a,Typeable a, Serialize a) - => RefQueue a -> String -> STM(Maybe a) -pickElemSTM tv key1= do - Queue name imp out <- readQRef tv - let xs= out ++ Prelude.reverse imp - when (not $ Prelude.null imp) $ writeDBRef tv $ Queue name [] xs - case Prelude.filter (\x-> key x == key1) xs of - [] -> return $ Nothing - (x:_) -> return $ Just x - --- | Update the first element of the queue with a new element with the same key -updateElem :: (Indexable a,Typeable a, Serialize a) - => RefQueue a -> a -> IO() -updateElem tv x = atomically $ updateElemSTM tv x - --- | Version in the STM monad -updateElemSTM :: (Indexable a,Typeable a, Serialize a) - => RefQueue a -> a -> STM() -updateElemSTM tv v= do - Queue name imp out <- readQRef tv - let xs= out ++ Prelude.reverse imp - let xs'= Prelude.map (\x -> if key x == n then v else x) xs - writeDBRef tv $ Queue name [] xs' - where - n= key v - --- | Return the list of all elements in the queue and empty it -readAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] -readAll= atomically . readAllSTM - --- | A version in the STM monad -readAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] -readAllSTM tv= do - Queue name imp out <- readQRef tv - writeDBRef tv $ Queue name [] [] - return $ out ++ Prelude.reverse imp - --- | Delete all the elements of the queue that has the key of the parameter passed -deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO () -deleteElem tv x= atomically $ deleteElemSTM tv x - --- | Verison in the STM monad -deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM () -deleteElemSTM tv x= do - Queue name imp out <- readQRef tv - let xs= out ++ Prelude.reverse imp - writeDBRef tv $ Queue name [] $ Prelude.filter (\x-> key x /= k) xs - where - k=key x - +{-# OPTIONS -XDeriveDataTypeable + -XTypeSynonymInstances + -XMultiParamTypeClasses + -XExistentialQuantification + -XOverloadedStrings + -XFlexibleInstances + -XUndecidableInstances + -XFunctionalDependencies + + #-} + +{- | +A persistent, transactional collection with Queue interface as well as + indexed access by key. + + Uses default persistence. See "Data.TCache.DefaultPersistence" + +-} +{- +NOTES +TODO: +data.persistent collection + convertirlo en un tree + añadiendo elementos node Node (refQueue a) + implementar un query language + by key + by attribute (addAttibute) + by class + xpath + implementar un btree sobre el +-} +module Data.Persistent.Collection ( +RefQueue(..), getQRef, +pop,popSTM,pick, flush, flushSTM, +pickAll, pickAllSTM, push,pushSTM, +pickElem, pickElemSTM, readAll, readAllSTM, +deleteElem, deleteElemSTM,updateElem,updateElemSTM, +unreadSTM,isEmpty,isEmptySTM +) where +import Data.Typeable +import Control.Concurrent.STM(STM,atomically, retry) +import Control.Monad +import Data.TCache.DefaultPersistence + +import Data.TCache +import System.IO.Unsafe +import Data.RefSerialize +import Data.ByteString.Lazy.Char8 +import Data.RefSerialize + +import Debug.Trace + +a !> b= trace b a + + + + +instance Indexable (Queue a) where + key (Queue k _ _)= queuePrefix ++ k + + + + +data Queue a= Queue {name :: String, imp :: [a], out :: [a]} deriving (Typeable) + + + +instance Serialize a => Serialize (Queue a) where + showp (Queue n i o)= showp n >> showp i >> showp o + readp = return Queue `ap` readp `ap` readp `ap` readp +-- do +-- n <- readp +-- i <- readp +-- o <- readp +-- return $ Queue n i o + + + + +queuePrefix= "Queue#" +lenQPrefix= Prelude.length queuePrefix + + + +instance Serialize a => Serializable (Queue a ) where + serialize = runW . showp + deserialize = runR readp + +-- | A queue reference +type RefQueue a= DBRef (Queue a) + +-- | push an element at the top of the queue +unreadSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () +unreadSTM queue x= do + r <- readQRef queue + writeDBRef queue $ doit r + where + doit (Queue n imp out) = Queue n imp ( x : out) + + +-- | Check if the queue is empty +isEmpty :: (Typeable a, Serialize a) => RefQueue a -> IO Bool +isEmpty = atomically . isEmptySTM + +isEmptySTM :: (Typeable a, Serialize a) => RefQueue a -> STM Bool +isEmptySTM queue= do + r <- readDBRef queue + return $ case r of + Nothing -> True + Just (Queue _ [] []) -> True + _ -> False + + + +-- | Get the reference to new or existing queue trough its name +getQRef :: (Typeable a, Serialize a) => String -> RefQueue a +getQRef n = getDBRef . key $ Queue n undefined undefined + + +-- | Empty the queue (factually, it is deleted) +flush :: (Typeable a, Serialize a) => RefQueue a -> IO () +flush = atomically . flushSTM + +-- | Version in the STM monad +flushSTM :: (Typeable a, Serialize a) => RefQueue a -> STM () +flushSTM tv= delDBRef tv + +-- | Read the first element in the queue and delete it (pop) +pop + :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name + -> IO a -- ^ the returned elems +pop tv = atomically $ popSTM tv + + +readQRef :: (Typeable a, Serialize a) => RefQueue a -> STM(Queue a) +readQRef tv= do + mdx <- readDBRef tv + case mdx of + Nothing -> do + let q= Queue ( Prelude.drop lenQPrefix $ keyObjDBRef tv) [] [] + writeDBRef tv q + return q + Just dx -> + return dx + +-- | Version in the STM monad +popSTM :: (Typeable a, Serialize a) => RefQueue a + -> STM a +popSTM tv=do + dx <- readQRef tv + doit dx + + where + + doit (Queue n [x] [])= do + writeDBRef tv $ (Queue n [] []) + return x + doit (Queue _ [] []) = retry + doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) + doit (Queue n imp list ) = do + writeDBRef tv (Queue n imp (Prelude.tail list )) + return $ Prelude.head list + +-- | Read the first element in the queue but it does not delete it +pick + :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name + -> IO a -- ^ the returned elems +pick tv = atomically $ do + dx <- readQRef tv + doit dx + where + doit (Queue _ [x] [])= return x + doit (Queue _ [] []) = retry + doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) + doit (Queue n imp list ) = return $ Prelude.head list + +-- | Push an element in the queue +push :: (Typeable a, Serialize a) => RefQueue a -> a -> IO () +push tv v = atomically $ pushSTM tv v + +-- | Version in the STM monad +pushSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () +pushSTM tv v= + readQRef tv >>= \ ((Queue n imp out)) -> writeDBRef tv $ Queue n (v : imp) out + +-- | Return the list of all elements in the queue. The queue remains unchanged +pickAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] +pickAll= atomically . pickAllSTM + +-- | Version in the STM monad +pickAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] +pickAllSTM tv= do + (Queue name imp out) <- readQRef tv + return $ out ++ Prelude.reverse imp + +-- | Return the first element in the queue that has the given key +pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a) +pickElem tv key= atomically $ pickElemSTM tv key + +-- | Version in the STM monad +pickElemSTM :: (Indexable a,Typeable a, Serialize a) + => RefQueue a -> String -> STM(Maybe a) +pickElemSTM tv key1= do + Queue name imp out <- readQRef tv + let xs= out ++ Prelude.reverse imp + when (not $ Prelude.null imp) $ writeDBRef tv $ Queue name [] xs + case Prelude.filter (\x-> key x == key1) xs of + [] -> return $ Nothing + (x:_) -> return $ Just x + +-- | Update the first element of the queue with a new element with the same key +updateElem :: (Indexable a,Typeable a, Serialize a) + => RefQueue a -> a -> IO() +updateElem tv x = atomically $ updateElemSTM tv x + +-- | Version in the STM monad +updateElemSTM :: (Indexable a,Typeable a, Serialize a) + => RefQueue a -> a -> STM() +updateElemSTM tv v= do + Queue name imp out <- readQRef tv + let xs= out ++ Prelude.reverse imp + let xs'= Prelude.map (\x -> if key x == n then v else x) xs + writeDBRef tv $ Queue name [] xs' + where + n= key v + +-- | Return the list of all elements in the queue and empty it +readAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] +readAll= atomically . readAllSTM + +-- | A version in the STM monad +readAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] +readAllSTM tv= do + Queue name imp out <- readQRef tv + writeDBRef tv $ Queue name [] [] + return $ out ++ Prelude.reverse imp + +-- | Delete all the elements of the queue that has the key of the parameter passed +deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO () +deleteElem tv x= atomically $ deleteElemSTM tv x + +-- | Verison in the STM monad +deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM () +deleteElemSTM tv x= do + Queue name imp out <- readQRef tv + let xs= out ++ Prelude.reverse imp + writeDBRef tv $ Queue name [] $ Prelude.filter (\x-> key x /= k) xs + where + k=key x + diff --git a/Data/Persistent/IDynamic.hs b/Data/Persistent/IDynamic.hs --- a/Data/Persistent/IDynamic.hs +++ b/Data/Persistent/IDynamic.hs @@ -20,7 +20,7 @@ import System.IO.Unsafe import Data.TCache import Data.TCache.Defs -import Data.RefSerialize + import Data.Char (showLitChar) import Data.ByteString.Lazy.Char8 as B @@ -121,14 +121,14 @@ case t of DRight x -> return $ runW (showp x) == str -- !> ("R "++ (show $ unpack $ runW (showp x))) DLeft (str', _) -> return $ str== str' -- !> ("L "++ (show $ unpack str' )) - + fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a fromIDyn x= case safeFromIDyn x of Left s -> error s Right v -> v -safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a +safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a safeFromIDyn (d@(IDyn r))= final where final= unsafePerformIO $ do t <- readIORef r diff --git a/Data/TCache.hs b/Data/TCache.hs --- a/Data/TCache.hs +++ b/Data/TCache.hs @@ -1,1036 +1,1040 @@ -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable - , FlexibleInstances, UndecidableInstances #-} - -{- | TCache is a transactional cache with configurable persitence that permits -STM transactions with objects that syncronize sincromous or asyncronously with -their user defined storages. Default persistence in files is provided by default - - TCache implements ''DBRef' 's . They are persistent STM references with a typical Haskell interface. -simitar to TVars ('newDBRef', 'readDBRef', 'writeDBRef' etc) but with added. persistence -. DBRefs are serializable, so they can be stored and retrieved. -Because they are references,they point to other serializable registers. -This permits persistent mutable Inter-object relations - -For simple transactions of lists of objects of the same type TCache implements -inversion of control primitives 'withSTMResources' and variants, that call pure user defined code for registers update. Examples below. - -Triggers in "Data.TCache.Triggers" are user defined hooks that are called back on register updates. -.They are used internally for indexing. - -"Data.TCache.IndexQuery" implements an straighforwards pure haskell type safe query language based - on register field relations. This module must be imported separately. - -"Data.TCache.IndexText" add full text search and content search to the query language - -"Data.TCache.DefaultPersistence" has instances for key indexation , serialization - and default file persistence. The file persistence is more reliable, and the embedded IO reads inside STM transactions are safe. - -"Data.Persistent.Collection" implements a persistent, transactional collection with Queue interface as well as - indexed access by key - --} - - - - -module Data.TCache ( --- * Inherited from 'Control.Concurrent.STM' and variations - - atomically - ,atomicallySync - ,STM - ,unsafeIOToSTM - ,safeIOToSTM - --- * 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. - -A @DBRef@ is associated with its referred object trough its key. -Since DBRefs are serializable, they can be elements of mutable cached objects themselves. 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 checked for equality so on. -The creation of a DBRef, trough 'getDBRef' is pure. This permits an efficient lazy access to the - registers trouth their DBRefs by lazy marshalling of the register content on demand. - -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 cache lookups everytime the object is accessed - -DBRef's and @*Resource(s)@ primitives are completely interoperable. The latter operate implicitly with DBRef's - --} - - -,DBRef -,getDBRef -,keyObjDBRef -,newDBRef ---,newDBRefIO -,readDBRef -,readDBRefs -,writeDBRef -,delDBRef - --- * @IResource@ class -{- | cached objects must be instances of IResource. -Such instances can be implicitly derived trough auxiliary clasess for file persistence --} -,IResource(..) - --- * Operations with cached objects -{- | implement inversion of control primitives where the user defines the objects to retrive. The primitives -then call a the defined function that, determines how to transform the objects retrieved,wich are sent -back to the storage and a result is returned. - -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(..) -- data definition used to communicate object Inserts and Deletes to the cache -,resources -- empty resources -,withSTMResources -,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} - - main= 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 -@ - -gives: - -> main -> 2 -> Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]} - --} - -,addTrigger - --- * Cache control -{-- | - -The mechanism for dropping elements from the cache is too lazy. `flushDBRef`, for example -just delete the data element from the TVar, but the TVar node -remains attached to the table so there is no decrement on the number of elements. -The element is garbage collected unless you have a direct reference to the element, not the DBRef -Note that you can still have a valid reference to this element, but this element is no longer -in the cache. The usual thing is that you do not have it, and the element will be garbage -collected (but still there will be a NotRead entry for this key!!!). If the DBRef is read again, the -TCache will go to permanent storage to retrieve it. - -clear opertions such `clearsyncCache` does something similar: it does not delete the -element from the cache. It just inform the garbage collector that there is no longer necessary to maintain -the element in the cache. So if the element has no other references (maybe you keep a -variable that point to that DBRef) it will be GCollected. -If this is not possible, it will remain in the cache and will be treated as such, -until the DBRef is no longer referenced by the program. This is done by means of a weak pointer - -All these complications are necessary because the programmer can handle DBRefs directly, -so the cache has no complete control of the DBRef life cycle, short to speak. - -a DBRef can be in the states: - -- `Exist`: it is in the cache - -- `DoesNotExist`: neither is in the cache neither in storage: it is like a cached "notfound" to -speed up repeated failed requests - -- `NotRead`: may exist or not in permanent storage, but not in the cache - - -In terms of Garbage collection it may be: - - - -1 - pending garbage collection: attached to the hashtable by means of a weak pointer: delete it asap - -2 - cached: attached by a direct pointer and a weak pointer: It is being cached - - -clearsyncCache just pass elements from 2 to 1 - ---} -,flushDBRef -,flushKey -,invalidateKey -,flushAll -,Cache -,setCache -,newCache ---,refcache -,syncCache -,setConditions -,clearSyncCache -,numElems -,syncWrite -,SyncMode(..) -,clearSyncCacheProc -,defaultCheck --- * Other -,onNothing -) -where - - -import GHC.Conc -import Control.Monad(when) -import qualified Data.HashTable.IO as H -import Data.IORef -import System.IO.Unsafe -import System.IO(hPutStr, stderr) -import Data.Maybe -import Data.Char(isSpace) -import Data.TCache.Defs -import Data.TCache.IResource -import Data.TCache.Triggers -import Control.Exception -import Data.Typeable -import System.Time -import System.Mem -import System.Mem.Weak - -import Control.Concurrent.MVar -import Control.Exception(catch, throw,evaluate) - ---import Debug.Trace ---(!>) = flip trace - --- 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 = H.BasicHashTable 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 - --- | Creates a new cache. Experimental -newCache :: IO (Ht , Integer) -newCache =do - c <- H.new -- (==) H.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's O(n). -numElems :: IO Int -numElems= do - (cache, _) <- readIORef refcache - elems <- H.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 -- !> ("delete " ++ k) - -fixToCache :: (IResource a, Typeable a) => DBRef a -> IO () -fixToCache dbref@(DBRef k tv)= do - (cache, _) <- readIORef refcache - w <- mkWeakPtr dbref $ Just $ fixToCache dbref - H.insert cache k (CacheElem (Just dbref) w) - return() - --- | 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 (-1) - return $ Just x - --- | Read multiple DBRefs in a single request using the new 'readResourcesByKey' -readDBRefs :: (IResource a, Typeable a) => [DBRef a] -> STM [(Maybe a)] -readDBRefs dbrefs= do - let mf (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 $ Right $ Just x - DoNotExist -> return $ Right Nothing - NotRead -> return $ Left key - inCache <- mapM mf dbrefs - let pairs = foldr(\pair@(x,dbr) xs -> case x of Left k -> pair:xs; _ -> xs ) [] $ zip inCache dbrefs - let (toReadKeys, dbrs) = unzip pairs - let fromLeft (Left k)= k - formLeft _ = error "this will never happen" - rs <- safeIOToSTM . readResourcesByKey $ map fromLeft toReadKeys - let processTVar (r, DBRef key tv)= do - case r of - Nothing -> writeTVar tv DoNotExist - Just x -> do - t <- unsafeIOToSTM timeInteger - writeTVar tv $ Exist $ Elem x t (-1) - - mapM_ processTVar $ zip rs dbrs - let mix (Right x:xs) ys = x:mix xs ys - mix (Left _:xs) (y:ys)= y:mix xs ys - - return $ mix inCache rs - --- | 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 --- --- WARNING: the value to be written in the DBRef must be fully evaluated. Delayed evaluations at --- serialization time can cause inconsistencies in the database. --- In future releases this will be enforced. -writeDBRef :: (IResource a, Typeable a) => DBRef a -> a -> STM () -writeDBRef dbref@(DBRef key tv) x= x `seq` 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 str1= readit str - where - str = dropWhile isSpace str1 - readit ('D':'B':'R':'e':'f':' ':'\"':str1)= - let (key,nstr) = break (== '\"') str1 - in [( getDBRef key :: DBRef a, tail nstr)] - readit _ = [] - -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. -{-# NOINLINE getDBRef #-} -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 -- !> ("getDBRef "++ key) - takeMVar getRefFlag - r <- H.lookup cache key - case r of - Just (CacheElem mdb w) -> do - putMVar getRefFlag () - mr <- deRefWeak w - case mr of - Just dbref@(DBRef _ tv) -> - case mdb of - Nothing -> return $! castErr dbref -- !> "just" - Just _ -> do - H.insert cache key (CacheElem Nothing w) --to notify when the DBREf leave its reference - return $! castErr dbref - Nothing -> finalize w >> getDBRef1 key -- !> "finalize" -- the weak pointer has not executed his finalizer - - Nothing -> do - tv <- newTVarIO NotRead -- !> "Nothing" - dbref <- evaluate $ DBRef key tv - w <- mkWeakPtr dbref . Just $ fixToCache dbref - H.insert cache key (CacheElem Nothing w) - putMVar getRefFlag () - return dbref - -getRefFlag= unsafePerformIO $ newMVar () - -{- | 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 $ fixToCache dbref - H.insert 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)) -- ^ ThTCache.hse 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 --- if you need to create the reference and the reference content, use 'newDBRef' -{-# NOINLINE newDBRef #-} -newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) -newDBRef x = do - let ref= getDBRef $! keyResource x - - mr <- readDBRef ref - case mr of - Nothing -> writeDBRef ref x >> return ref -- !> " write" - Just r -> return ref -- !> " non write" - ---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 $ fixToCache dbref --- H.insert 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 - applyTriggers [dbref] [Nothing] - writeTVar tv DoNotExist - - safeIOToSTM . criticalSection saving $ delResource x - - Nothing -> return () - - - --- | Handles Nothing cases in a simpler way than runMaybeT. --- it is used in infix notation. for example: --- --- @result <- readDBRef ref \`onNothing\` error (\"Not found \"++ keyObjDBRef ref)@ --- --- or --- --- @result <- readDBRef ref \`onNothing\` return someDefaultValue@ -onNothing io onerr= do - my <- io - case my of - Just y -> return y - Nothing -> onerr - --- | 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 - --- | flush the element with the given key -flushKey key= do - (cache,time) <- unsafeIOToSTM $ readIORef refcache - c <- unsafeIOToSTM $ H.lookup cache key - case c of - Just (CacheElem _ w) -> do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just (DBRef k tv) -> writeTVar tv NotRead - Nothing -> unsafeIOToSTM (finalize w) >> flushKey key - Nothing -> return () - --- | label the object as not existent in database -invalidateKey key= do - (cache,time) <- unsafeIOToSTM $ readIORef refcache - c <- unsafeIOToSTM $ H.lookup cache key - case c of - Just (CacheElem _ w) -> do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just (DBRef k tv) -> writeTVar tv DoNotExist - Nothing -> unsafeIOToSTM (finalize w) >> flushKey key - Nothing -> return () - - --- | drops the entire cache. -flushAll :: STM () -flushAll = do - (cache,time) <- unsafeIOToSTM $ readIORef refcache - elms <- unsafeIOToSTM $ H.toList cache - mapM_ (del cache) elms - where - del cache ( _ , CacheElem _ w)= do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just (DBRef _ tv) -> writeTVar tv NotRead - 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' --- --- WARNING: To catch evaluations errors at the right place, the values to be written must be fully evaluated. --- Errors in delayed evaluations at serialization time can cause inconsistencies in the database. - -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 - applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing `asTypeOf` (Just(head ds)))) - delListFromHash cache ds - releaseTPVars as cache - - safeIOToSTM . criticalSection saving $ mapM_ delResource ds - 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])@ -{-# INLINE withResource #-} -withResource:: (IResource a, Typeable a) => a -> (Maybe a-> a) -> 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 [] ()@ -{-# INLINE withResources #-} -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}@ -{-# INLINE getResource #-} -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@ -{-# INLINE getResources #-} -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] @ -{-# INLINE deleteResource #-} -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) ()@ -{-# INLINE deleteResources #-} -deleteResources :: (IResource a, Typeable a) => [a] -> IO () -deleteResources rs= atomically $ withSTMResources rs f1 where - f1 mrs = resources {toDelete=catMaybes mrs} - -{-# INLINE takeDBRefs #-} -takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht -> CheckTPVarFlags -> STM [Maybe (DBRef a)] -takeDBRefs rs cache addToHash= mapM (takeDBRef cache addToHash) rs - - -{-# NOINLINE takeDBRef #-} -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 <- readResource x - case mr of - Nothing -> return Nothing - Just r2 -> do - ti <- timeInteger - tvr <- newTVarIO . Exist $ Elem r2 ti (-1) - case flags of - NoAddToHash -> return . Just $ DBRef key tvr - AddToHash -> do - dbref <- evaluate $ DBRef key tvr - w <- mkWeakPtr dbref . Just $ fixToCache dbref - H.insert cache key (CacheElem (Just dbref) w) - return $ Just dbref - -- !> ("readToCache "++ key) - - - -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@(DBRef key tv) -> do - applyTriggers [dbref] [Just (castErr r)] - t <- unsafeIOToSTM timeInteger - writeTVar tv . Exist $ Elem (castErr r) t t - - - Nothing -> do - ti <- unsafeIOToSTM timeInteger - tvr <- newTVar NotRead - dbref <- unsafeIOToSTM . evaluate $ DBRef keyr tvr - applyTriggers [dbref] [Just r] - writeTVar tvr . Exist $ Elem r ti ti - w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ fixToCache dbref - unsafeIOToSTM $ H.insert 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@(DBRef _ tv) -> do - writeTVar tv DoNotExist - Nothing -> do - unsafeIOToSTM (finalize w) >> del x - - - -updateListToHash hash kv= mapM (update1 hash) kv where - update1 h (k,v)= H.insert h k v - - - --- | Start the thread that periodically call `clearSyncCache` to clean and writes on the persistent storage. --- it is indirecly set by means of `syncWrite`, since it is more higuer level. I recommend to use the latter --- Otherwise, 'syncCache' or `clearSyncCache` or `atomicallySync` 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 = do - threadDelay $ time * 1000000 - handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do - clearSyncCache check sizeObjects -- !> "CLEAR" - clear - -criticalSection mv f= bracket - (takeMVar mv) - (putMVar mv) - $ const $ f - --- | Force the atomic write of all cached objects modified since the last save into permanent storage. --- Cache writes allways save a coherent state. As allways, only the modified objects are written. -syncCache :: IO () -syncCache = criticalSection saving $ do - (cache,lastSync) <- readIORef refcache --`debug` "syncCache" - t2<- timeInteger - elems <- H.toList cache - (tosave,_,_) <- atomically $ extract elems lastSync - save tosave - writeIORef refcache (cache, t2) - - -data SyncMode= Synchronous -- ^ sync state to permanent storage when `atomicallySync` is invoked - | Asyncronous - {frecuency :: Int -- ^ number of seconds between saves when asyncronous - ,check :: (Integer-> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example - ,cacheSize :: Int -- ^ size of the cache when async - } - | SyncManual -- ^ use `syncCache` to write the state - - - - -tvSyncWrite= unsafePerformIO $ newIORef (Synchronous, Nothing) - --- | Specify the cache synchronization policy with permanent storage. See `SyncMode` for details -syncWrite:: SyncMode -> IO() -syncWrite mode= do - (_,thread) <- readIORef tvSyncWrite - when (isJust thread ) $ killThread . fromJust $ thread - case mode of - Synchronous -> modeWrite - SyncManual -> modeWrite - Asyncronous time check maxsize -> do - th <- clearSyncCacheProc time check maxsize >> return() - writeIORef tvSyncWrite (mode,Just th) - where - modeWrite= writeIORef tvSyncWrite (mode, Nothing) - - --- | Perform a synchronization of the cache with permanent storage once executed the STM transaction --- when 'syncWrite' policy is `Synchronous` -atomicallySync :: STM a -> IO a -atomicallySync proc=do - r <- atomically proc - sync - return r - - where - sync= do - (savetype,_) <- readIORef tvSyncWrite - case savetype of - Synchronous -> do - syncCache - _ -> return () - - --- |Saves the unsaved elems of the cache. --- Cache writes allways save a coherent state. --- Unlike `syncChace` this call deletes some elems of the cache when the number of elems > @sizeObjects@. --- The deletion depends on the check criteria, expressed by the first parameter. --- 'defaultCheck' is the one implemented to be passed by default. Look at it to understand the clearing criteria. -clearSyncCache :: (Integer -> Integer-> Integer-> Bool)-> Int -> IO () -clearSyncCache check sizeObjects= criticalSection saving $ do - (cache,lastSync) <- readIORef refcache - t <- timeInteger - elems <- H.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.insert cache key $ CacheElem Nothing w - writeTVar tv NotRead - else return () - _ -> return() - - - --- | This 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 - (pre, post) <- readIORef refConditions - pre -- !> (concatMap (\(Filtered x) -> keyResource x)tosave) - mapM (\(Filtered x) -> writeResource x) tosave - post - - -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 -- !> ("rejected->" ++ keyResource r) - - _ -> filter1 sav tofilter (n+1) rest - - --- | Assures that the IO computation finalizes no matter if the STM transaction --- is aborted or retried. The IO computation run in a different thread. --- The STM transaction wait until the completion of the IO procedure (or retry as usual). --- --- It can be retried if the embedding STM computation is retried --- so the IO computation must be idempotent. --- Exceptions are bubbled up to the STM transaction -safeIOToSTM :: IO a -> STM a -safeIOToSTM req= unsafeIOToSTM $ do - tv <- newEmptyMVar - forkIO $ (req >>= putMVar tv . Right) - `Control.Exception.catch` - (\(e :: SomeException) -> putMVar tv $ Left e ) - r <- takeMVar tv - case r of - Right x -> return x - Left e -> throw e - - - +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable + , FlexibleInstances, UndecidableInstances #-} + +{- | TCache is a transactional cache with configurable persitence that permits +STM transactions with objects that syncronize sincromous or asyncronously with +their user defined storages. Default persistence in files is provided by default + + TCache implements ''DBRef' 's . They are persistent STM references with a typical Haskell interface. +simitar to TVars ('newDBRef', 'readDBRef', 'writeDBRef' etc) but with added. persistence +. DBRefs are serializable, so they can be stored and retrieved. +Because they are references,they point to other serializable registers. +This permits persistent mutable Inter-object relations + +For simple transactions of lists of objects of the same type TCache implements +inversion of control primitives 'withSTMResources' and variants, that call pure user defined code for registers update. Examples below. + +Triggers in "Data.TCache.Triggers" are user defined hooks that are called back on register updates. +.They are used internally for indexing. + +"Data.TCache.IndexQuery" implements an straighforwards pure haskell type safe query language based + on register field relations. This module must be imported separately. + +"Data.TCache.IndexText" add full text search and content search to the query language + +"Data.TCache.DefaultPersistence" has instances for key indexation , serialization + and default file persistence. The file persistence is more reliable, and the embedded IO reads inside STM transactions are safe. + +"Data.Persistent.Collection" implements a persistent, transactional collection with Queue interface as well as + indexed access by key + +-} + + + + +module Data.TCache ( +-- * Inherited from 'Control.Concurrent.STM' and variations + + atomically + ,atomicallySync + ,STM + ,unsafeIOToSTM + ,safeIOToSTM + +-- * 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. + +A @DBRef@ is associated with its referred object trough its key. +Since DBRefs are serializable, they can be elements of mutable cached objects themselves. 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 checked for equality so on. +The creation of a DBRef, trough 'getDBRef' is pure. This permits an efficient lazy access to the + registers trouth their DBRefs by lazy marshalling of the register content on demand. + +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 cache lookups everytime the object is accessed + +DBRef's and @*Resource(s)@ primitives are completely interoperable. The latter operate implicitly with DBRef's + +-} + + +,DBRef +,getDBRef +,keyObjDBRef +,newDBRef +--,newDBRefIO +,readDBRef +,readDBRefs +,writeDBRef +,delDBRef + +-- * @IResource@ class +{- | cached objects must be instances of IResource. +Such instances can be implicitly derived trough auxiliary clasess for file persistence +-} +,IResource(..) + +-- * Operations with cached objects +{- | implement inversion of control primitives where the user defines the objects to retrive. The primitives +then call a the defined function that, determines how to transform the objects retrieved,wich are sent +back to the storage and a result is returned. + +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(..) -- data definition used to communicate object Inserts and Deletes to the cache +,resources -- empty resources +,withSTMResources +,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} + + main= 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 +@ + +gives: + +> main +> 2 +> Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]} + +-} + +,addTrigger + +-- * Cache control +{-- | + +The mechanism for dropping elements from the cache is too lazy. `flushDBRef`, for example +just delete the data element from the TVar, but the TVar node +remains attached to the table so there is no decrement on the number of elements. +The element is garbage collected unless you have a direct reference to the element, not the DBRef +Note that you can still have a valid reference to this element, but this element is no longer +in the cache. The usual thing is that you do not have it, and the element will be garbage +collected (but still there will be a NotRead entry for this key!!!). If the DBRef is read again, the +TCache will go to permanent storage to retrieve it. + +clear opertions such `clearsyncCache` does something similar: it does not delete the +element from the cache. It just inform the garbage collector that there is no longer necessary to maintain +the element in the cache. So if the element has no other references (maybe you keep a +variable that point to that DBRef) it will be GCollected. +If this is not possible, it will remain in the cache and will be treated as such, +until the DBRef is no longer referenced by the program. This is done by means of a weak pointer + +All these complications are necessary because the programmer can handle DBRefs directly, +so the cache has no complete control of the DBRef life cycle, short to speak. + +a DBRef can be in the states: + +- `Exist`: it is in the cache + +- `DoesNotExist`: neither is in the cache neither in storage: it is like a cached "notfound" to +speed up repeated failed requests + +- `NotRead`: may exist or not in permanent storage, but not in the cache + + +In terms of Garbage collection it may be: + + + +1 - pending garbage collection: attached to the hashtable by means of a weak pointer: delete it asap + +2 - cached: attached by a direct pointer and a weak pointer: It is being cached + + +clearsyncCache just pass elements from 2 to 1 + +--} +,flushDBRef +,flushKey +,invalidateKey +,flushAll +,Cache +,setCache +,newCache +--,refcache +,syncCache +,setConditions +,clearSyncCache +,numElems +,syncWrite +,SyncMode(..) +,clearSyncCacheProc +,defaultCheck +-- * Other +,onNothing +) +where + + +import GHC.Conc +import Control.Monad(when) +import qualified Data.HashTable.IO as H +import Data.IORef +import System.IO.Unsafe +import System.IO(hPutStr, stderr) +import Data.Maybe +import Data.Char(isSpace) +import Data.TCache.Defs +import Data.TCache.IResource +import Data.TCache.Triggers +import Control.Exception +import Data.Typeable +import System.Time +import System.Mem +import System.Mem.Weak + +import Control.Concurrent.MVar +import Control.Exception(catch, throw,evaluate) + +--import Debug.Trace +--(!>) = flip trace + +-- 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 = H.BasicHashTable 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 +{-# NOINLINE refcache #-} +refcache :: Cache +refcache =unsafePerformIO $ newCache >>= newIORef + +-- | Creates a new cache. Experimental +newCache :: IO (Ht , Integer) +newCache =do + c <- H.new -- (==) H.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's O(n). +numElems :: IO Int +numElems= do + (cache, _) <- readIORef refcache + elems <- H.toList cache + return $ length elems + +{-# NOINLINE deRefWeakSTM #-} +deRefWeakSTM = unsafeIOToSTM . deRefWeak + +--deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO () +--deleteFromCache (DBRef k tv)= do +-- (cache, _) <- readIORef refcache +-- H.delete cache k -- !> ("delete " ++ k) + +fixToCache :: (IResource a, Typeable a) => DBRef a -> IO () +fixToCache dbref@(DBRef k tv)= do + (cache, _) <- readIORef refcache + w <- mkWeakPtr dbref $ Just $ fixToCache dbref + H.insert cache k (CacheElem (Just dbref) w) + return() + +-- | 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 (-1) + return $ Just x + +-- | Read multiple DBRefs in a single request using the new 'readResourcesByKey' +readDBRefs :: (IResource a, Typeable a) => [DBRef a] -> STM [(Maybe a)] +readDBRefs dbrefs= do + let mf (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 $ Right $ Just x + DoNotExist -> return $ Right Nothing + NotRead -> return $ Left key + inCache <- mapM mf dbrefs + let pairs = foldr(\pair@(x,dbr) xs -> case x of Left k -> pair:xs; _ -> xs ) [] $ zip inCache dbrefs + let (toReadKeys, dbrs) = unzip pairs + let fromLeft (Left k)= k + formLeft _ = error "this will never happen" + rs <- safeIOToSTM . readResourcesByKey $ map fromLeft toReadKeys + let processTVar (r, DBRef key tv)= do + case r of + Nothing -> writeTVar tv DoNotExist + Just x -> do + t <- unsafeIOToSTM timeInteger + writeTVar tv $ Exist $ Elem x t (-1) + + mapM_ processTVar $ zip rs dbrs + let mix (Right x:xs) ys = x:mix xs ys + mix (Left _:xs) (y:ys)= y:mix xs ys + + return $ mix inCache rs + +-- | 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 +-- +-- WARNING: the value to be written in the DBRef must be fully evaluated. Delayed evaluations at +-- serialization time can cause inconsistencies in the database. +-- In future releases this will be enforced. +writeDBRef :: (IResource a, Typeable a) => DBRef a -> a -> STM () +writeDBRef dbref@(DBRef key tv) x= x `seq` 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 str1= readit str + where + str = dropWhile isSpace str1 + readit ('D':'B':'R':'e':'f':' ':'\"':str1)= + let (key,nstr) = break (== '\"') str1 + in [( getDBRef key :: DBRef a, tail nstr)] + readit _ = [] + +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. +{-# NOINLINE getDBRef #-} +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 -- !> ("getDBRef "++ key) + takeMVar getRefFlag + r <- H.lookup cache key + case r of + Just (CacheElem mdb w) -> do + putMVar getRefFlag () + mr <- deRefWeak w + case mr of + Just dbref@(DBRef _ tv) -> + case mdb of + Nothing -> return $! castErr dbref -- !> "just" + Just _ -> do + H.insert cache key (CacheElem Nothing w) --to notify when the DBREf leave its reference + return $! castErr dbref + Nothing -> finalize w >> getDBRef1 key -- !> "finalize" -- the weak pointer has not executed his finalizer + + Nothing -> do + tv <- newTVarIO NotRead -- !> "Nothing" + dbref <- evaluate $ DBRef key tv + w <- mkWeakPtr dbref . Just $ fixToCache dbref + H.insert cache key (CacheElem Nothing w) + putMVar getRefFlag () + return dbref + +{-# NOINLINE getRefFlag #-} +getRefFlag= unsafePerformIO $ newMVar () + +{- | 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 $ fixToCache dbref + H.insert 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)) -- ^ ThTCache.hse 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 +-- if you need to create the reference and the reference content, use 'newDBRef' +{-# NOINLINE newDBRef #-} +newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) +newDBRef x = do + let ref= getDBRef $! keyResource x + + mr <- readDBRef ref + case mr of + Nothing -> writeDBRef ref x >> return ref -- !> " write" + Just r -> return ref -- !> " non write" + +--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 $ fixToCache dbref +-- H.insert 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 + applyTriggers [dbref] [Nothing] + writeTVar tv DoNotExist + + safeIOToSTM . criticalSection saving $ delResource x + + Nothing -> return () + + + +-- | Handles Nothing cases in a simpler way than runMaybeT. +-- it is used in infix notation. for example: +-- +-- @result <- readDBRef ref \`onNothing\` error (\"Not found \"++ keyObjDBRef ref)@ +-- +-- or +-- +-- @result <- readDBRef ref \`onNothing\` return someDefaultValue@ +onNothing io onerr= do + my <- io + case my of + Just y -> return y + Nothing -> onerr + +-- | 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 + +-- | flush the element with the given key +flushKey key= do + (cache,time) <- unsafeIOToSTM $ readIORef refcache + c <- unsafeIOToSTM $ H.lookup cache key + case c of + Just (CacheElem _ w) -> do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Just (DBRef k tv) -> writeTVar tv NotRead + Nothing -> unsafeIOToSTM (finalize w) >> flushKey key + Nothing -> return () + +-- | label the object as not existent in database +invalidateKey key= do + (cache,time) <- unsafeIOToSTM $ readIORef refcache + c <- unsafeIOToSTM $ H.lookup cache key + case c of + Just (CacheElem _ w) -> do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Just (DBRef k tv) -> writeTVar tv DoNotExist + Nothing -> unsafeIOToSTM (finalize w) >> flushKey key + Nothing -> return () + + +-- | drops the entire cache. +flushAll :: STM () +flushAll = do + (cache,time) <- unsafeIOToSTM $ readIORef refcache + elms <- unsafeIOToSTM $ H.toList cache + mapM_ (del cache) elms + where + del cache ( _ , CacheElem _ w)= do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Just (DBRef _ tv) -> writeTVar tv NotRead + 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' +-- +-- WARNING: To catch evaluations errors at the right place, the values to be written must be fully evaluated. +-- Errors in delayed evaluations at serialization time can cause inconsistencies in the database. + +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 + applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing `asTypeOf` (Just(head ds)))) + delListFromHash cache ds + releaseTPVars as cache + + safeIOToSTM . criticalSection saving $ mapM_ delResource ds + 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])@ +{-# INLINE withResource #-} +withResource:: (IResource a, Typeable a) => a -> (Maybe a-> a) -> 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 [] ()@ +{-# INLINE withResources #-} +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}@ +{-# INLINE getResource #-} +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@ +{-# INLINE getResources #-} +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] @ +{-# INLINE deleteResource #-} +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) ()@ +{-# INLINE deleteResources #-} +deleteResources :: (IResource a, Typeable a) => [a] -> IO () +deleteResources rs= atomically $ withSTMResources rs f1 where + f1 mrs = resources {toDelete=catMaybes mrs} + +{-# INLINE takeDBRefs #-} +takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht -> CheckTPVarFlags -> STM [Maybe (DBRef a)] +takeDBRefs rs cache addToHash= mapM (takeDBRef cache addToHash) rs + + +{-# NOINLINE takeDBRef #-} +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 <- readResource x + case mr of + Nothing -> return Nothing + Just r2 -> do + ti <- timeInteger + tvr <- newTVarIO . Exist $ Elem r2 ti (-1) + case flags of + NoAddToHash -> return . Just $ DBRef key tvr + AddToHash -> do + dbref <- evaluate $ DBRef key tvr + w <- mkWeakPtr dbref . Just $ fixToCache dbref + H.insert cache key (CacheElem (Just dbref) w) + return $ Just dbref + -- !> ("readToCache "++ key) + + + +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@(DBRef key tv) -> do + applyTriggers [dbref] [Just (castErr r)] + t <- unsafeIOToSTM timeInteger + writeTVar tv . Exist $ Elem (castErr r) t t + + + Nothing -> do + ti <- unsafeIOToSTM timeInteger + tvr <- newTVar NotRead + dbref <- unsafeIOToSTM . evaluate $ DBRef keyr tvr + applyTriggers [dbref] [Just r] + writeTVar tvr . Exist $ Elem r ti ti + w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ fixToCache dbref + unsafeIOToSTM $ H.insert 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@(DBRef _ tv) -> do + writeTVar tv DoNotExist + Nothing -> do + unsafeIOToSTM (finalize w) >> del x + + + +updateListToHash hash kv= mapM (update1 hash) kv where + update1 h (k,v)= H.insert h k v + + + +-- | Start the thread that periodically call `clearSyncCache` to clean and writes on the persistent storage. +-- it is indirecly set by means of `syncWrite`, since it is more higuer level. I recommend to use the latter +-- Otherwise, 'syncCache' or `clearSyncCache` or `atomicallySync` 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 = do + threadDelay $ time * 1000000 + handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do + clearSyncCache check sizeObjects -- !> "CLEAR" + clear + +criticalSection mv f= bracket + (takeMVar mv) + (putMVar mv) + $ const $ f + +-- | Force the atomic write of all cached objects modified since the last save into permanent storage. +-- Cache writes allways save a coherent state. As allways, only the modified objects are written. +syncCache :: IO () +syncCache = criticalSection saving $ do + (cache,lastSync) <- readIORef refcache --`debug` "syncCache" + t2<- timeInteger + elems <- H.toList cache + (tosave,_,_) <- atomically $ extract elems lastSync + save tosave + writeIORef refcache (cache, t2) + + +data SyncMode= Synchronous -- ^ sync state to permanent storage when `atomicallySync` is invoked + | Asyncronous + {frecuency :: Int -- ^ number of seconds between saves when asyncronous + ,check :: (Integer-> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example + ,cacheSize :: Int -- ^ size of the cache when async + } + | SyncManual -- ^ use `syncCache` to write the state + + + +{-# NOINLINE tvSyncWrite #-} +tvSyncWrite= unsafePerformIO $ newIORef (Synchronous, Nothing) + +-- | Specify the cache synchronization policy with permanent storage. See `SyncMode` for details +syncWrite:: SyncMode -> IO() +syncWrite mode= do + (_,thread) <- readIORef tvSyncWrite + when (isJust thread ) $ killThread . fromJust $ thread + case mode of + Synchronous -> modeWrite + SyncManual -> modeWrite + Asyncronous time check maxsize -> do + th <- clearSyncCacheProc time check maxsize >> return() + writeIORef tvSyncWrite (mode,Just th) + where + modeWrite= writeIORef tvSyncWrite (mode, Nothing) + + +-- | Perform a synchronization of the cache with permanent storage once executed the STM transaction +-- when 'syncWrite' policy is `Synchronous` +atomicallySync :: STM a -> IO a +atomicallySync proc=do + r <- atomically proc + sync + return r + + where + sync= do + (savetype,_) <- readIORef tvSyncWrite + case savetype of + Synchronous -> do + syncCache + _ -> return () + + +-- |Saves the unsaved elems of the cache. +-- Cache writes allways save a coherent state. +-- Unlike `syncChace` this call deletes some elems of the cache when the number of elems > @sizeObjects@. +-- The deletion depends on the check criteria, expressed by the first parameter. +-- 'defaultCheck' is the one implemented to be passed by default. Look at it to understand the clearing criteria. +clearSyncCache :: (Integer -> Integer-> Integer-> Bool)-> Int -> IO () +clearSyncCache check sizeObjects= criticalSection saving $ do + (cache,lastSync) <- readIORef refcache + t <- timeInteger + elems <- H.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.insert cache key $ CacheElem Nothing w + writeTVar tv NotRead + else return () + _ -> return() + + + +-- | This 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 + +{-# NOINLINE refConditions #-} +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) + +{-# NOINLINE saving #-} +saving= unsafePerformIO $ newMVar False + +save tosave = do + (pre, post) <- readIORef refConditions + pre -- !> (concatMap (\(Filtered x) -> keyResource x)tosave) + mapM (\(Filtered x) -> writeResource x) tosave + post + + +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 -- !> ("rejected->" ++ keyResource r) + + _ -> filter1 sav tofilter (n+1) rest + + +-- | Assures that the IO computation finalizes no matter if the STM transaction +-- is aborted or retried. The IO computation run in a different thread. +-- The STM transaction wait until the completion of the IO procedure (or retry as usual). +-- +-- It can be retried if the embedding STM computation is retried +-- so the IO computation must be idempotent. +-- Exceptions are bubbled up to the STM transaction +safeIOToSTM :: IO a -> STM a +safeIOToSTM req= unsafeIOToSTM $ do + tv <- newEmptyMVar + forkIO $ (req >>= putMVar tv . Right) + `Control.Exception.catch` + (\(e :: SomeException) -> putMVar tv $ Left e ) + r <- takeMVar tv + case r of + Right x -> return x + Left e -> throw e + + + diff --git a/Data/TCache/Memoization.hs b/Data/TCache/Memoization.hs --- a/Data/TCache/Memoization.hs +++ b/Data/TCache/Memoization.hs @@ -1,151 +1,151 @@ ------------------------------------------------------------------------------ --- --- Module : Memoization --- Copyright : Alberto GOmez Corona --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : Experimental --- Portability : Non portable (uses stablenames) --- --- | --- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable - , ExistentialQuantification - , FlexibleInstances - , TypeSynonymInstances #-} -module Data.TCache.Memoization (writeCached,cachedByKey,cachedByKeySTM,flushCached,cachedp,addrStr,Executable(..)) - -where -import Data.Typeable -import Data.TCache -import Data.TCache.Defs(Indexable(..)) -import System.Mem.StableName -import System.IO.Unsafe -import System.Time -import Data.Maybe(fromJust) -import Control.Monad.Trans -import Control.Monad.Identity -import Data.RefSerialize(addrHash,newContext) ---import Debug.Trace ---(!>)= flip trace - -data Cached a b= forall m.Executable m => Cached a (a -> m b) b Integer deriving Typeable - -context= unsafePerformIO newContext - --- | given a string, return a key that can be used in Indexable instances --- Of non persistent objects, such are cached objects (it changes fron execution to execution) --- . It uses `addrHash` -addrStr x= "addr" ++ show hash - where - hash = case unsafePerformIO $ addrHash context x of - Right x -> x - Left x -> x - --- | to execute a monad for the purpose of memoizing its result -class Executable m where - execute:: m a -> a - -instance Executable IO where - execute m = unsafePerformIO $! f1 m "" - where - f1 m x= m - -instance Executable Identity where - execute (Identity x)= x - -instance MonadIO Identity where - liftIO f= Identity $! unsafePerformIO $! f - - -cachedKeyPrefix = "cached" - -instance (Indexable a) => IResource (Cached a b) where - keyResource ch@(Cached a _ _ _)= cachedKeyPrefix ++ key a -- ++ unsafePerformIO (addrStr f ) - - writeResource _= return () - delResource _= return () - readResourceByKey k= return Nothing -- error $ "access By key is undefined for cached objects.key= " ++ k - - - readResource (Cached a f _ _)=do - TOD tnow _ <- getClockTime - let b = execute $ f a - return . Just $ Cached a f b tnow -- !> "readRe" - ---cache time f a= do --- TOD tnow _ <- getClockTime --- let b = execute $ f a --- withResources [] . const $ [Cached a f b tnow] -- !> "writeRe"] --- ---cacheKey key time f= cache time (const f) key - --- | memoize the result of a computation for a certain time. This is useful for caching costly data --- such web pages composed on the fly. --- --- time == 0 means infinite - ---getCachedRef :: (Indexable a,Typeable a, Typeable b) => a -> DBRef (Cached a b) ---getCachedRef x = getDBRef $ keyResource (Cached x (u u u) where u= undefined - -writeCached - :: (Typeable b, Typeable a, Indexable a, Executable m) => - a -> (a -> m b) -> b -> Integer -> STM () -writeCached a b c d= - withSTMResources [] . const $ resources{toAdd= [Cached a b c d] } - - -cached :: (Indexable a,Typeable a, Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a -> m b -cached time f a= liftIO . atomically $ cachedSTM time f a - -cachedSTM time f a= do - let prot= Cached a f undefined undefined - let ref= getDBRef $ keyResource prot - cho@(Cached _ _ b t) <- readDBRef ref `onNothing` fillIt ref prot - case time of - 0 -> return b - _ -> do - TOD tnow _ <- unsafeIOToSTM $ getClockTime - if tnow - t >= fromIntegral time - then do - Cached _ _ b _ <- fillIt ref prot - return b - else return b - where - -- has been invalidated by flushCached - fillIt ref proto= do - let r = unsafePerformIO $return . fromJust =<< readResource proto -- !> "fillIt" - writeDBRef ref r - return r - --- | Memoize the result of a computation for a certain time. A string 'key' is used to index the result --- --- The Int parameter is the timeout, in second after the last evaluation, after which the cached value will be discarded and the expression will be evaluated again if demanded --- . Time == 0 means no timeout -cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int -> m a -> m a -cachedByKey key time f = cached time (\_ -> f) key - -cachedByKeySTM :: (Typeable a, Executable m) => String -> Int -> m a -> STM a -cachedByKeySTM key time f = cachedSTM time (\_ -> f) key - --- Flush the cached object indexed by the key -flushCached :: String -> IO () -flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k -- !> "flushCached" - --- | a pure version of cached -cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b -cachedp f k = execute $ cached 0 (\x -> Identity $ f x) k - ---testmemo= do --- let f x = "hi"++x !> "exec1" --- let f1 x= "h0"++x !> "exec2" --- let beacon=1 --- let beacon2=2 --- print $ cachedp f (addrStr "sfs") --- print $ cachedp f (addrStr "sds") --- print $ cachedp f1 (addrStr "ssdfddd") --- print $ cachedp f1 (addrStr "sss") - - +----------------------------------------------------------------------------- +-- +-- Module : Memoization +-- Copyright : Alberto GOmez Corona +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : Experimental +-- Portability : Non portable (uses stablenames) +-- +-- | +-- +----------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable + , ExistentialQuantification + , FlexibleInstances + , TypeSynonymInstances #-} +module Data.TCache.Memoization (writeCached,cachedByKey,cachedByKeySTM,flushCached,cachedp,addrStr,Executable(..)) + +where +import Data.Typeable +import Data.TCache +import Data.TCache.Defs(Indexable(..)) +import System.Mem.StableName +import System.IO.Unsafe +import System.Time +import Data.Maybe(fromJust) +import Control.Monad.Trans +import Control.Monad.Identity +import Data.RefSerialize(addrHash,newContext) +--import Debug.Trace +--(!>)= flip trace + +data Cached a b= forall m.Executable m => Cached a (a -> m b) b Integer deriving Typeable + +context= unsafePerformIO newContext + +-- | given a string, return a key that can be used in Indexable instances +-- Of non persistent objects, such are cached objects (it changes fron execution to execution) +-- . It uses `addrHash` +addrStr x= "addr" ++ show hash + where + hash = case unsafePerformIO $ addrHash context x of + Right x -> x + Left x -> x + +-- | to execute a monad for the purpose of memoizing its result +class Executable m where + execute:: m a -> a + +instance Executable IO where + execute m = unsafePerformIO $! f1 m "" + where + f1 m x= m + +instance Executable Identity where + execute (Identity x)= x + +instance MonadIO Identity where + liftIO f= Identity $! unsafePerformIO $! f + + +cachedKeyPrefix = "cached" + +instance (Indexable a) => IResource (Cached a b) where + keyResource ch@(Cached a _ _ _)= cachedKeyPrefix ++ key a -- ++ unsafePerformIO (addrStr f ) + + writeResource _= return () + delResource _= return () + readResourceByKey k= return Nothing -- error $ "access By key is undefined for cached objects.key= " ++ k + + + readResource (Cached a f _ _)=do + TOD tnow _ <- getClockTime + let b = execute $ f a + return . Just $ Cached a f b tnow -- !> "readRe" + +--cache time f a= do +-- TOD tnow _ <- getClockTime +-- let b = execute $ f a +-- withResources [] . const $ [Cached a f b tnow] -- !> "writeRe"] +-- +--cacheKey key time f= cache time (const f) key + +-- | memoize the result of a computation for a certain time. This is useful for caching costly data +-- such web pages composed on the fly. +-- +-- time == 0 means infinite + +--getCachedRef :: (Indexable a,Typeable a, Typeable b) => a -> DBRef (Cached a b) +--getCachedRef x = getDBRef $ keyResource (Cached x (u u u) where u= undefined + +writeCached + :: (Typeable b, Typeable a, Indexable a, Executable m) => + a -> (a -> m b) -> b -> Integer -> STM () +writeCached a b c d= + withSTMResources [] . const $ resources{toAdd= [Cached a b c d] } + + +cached :: (Indexable a,Typeable a, Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a -> m b +cached time f a= liftIO . atomically $ cachedSTM time f a + +cachedSTM time f a= do + let prot= Cached a f undefined undefined + let ref= getDBRef $ keyResource prot + cho@(Cached _ _ b t) <- readDBRef ref `onNothing` fillIt ref prot + case time of + 0 -> return b + _ -> do + TOD tnow _ <- unsafeIOToSTM $ getClockTime + if tnow - t >= fromIntegral time + then do + Cached _ _ b _ <- fillIt ref prot + return b + else return b + where + -- has been invalidated by flushCached + fillIt ref proto= do + let r = unsafePerformIO $return . fromJust =<< readResource proto -- !> "fillIt" + writeDBRef ref r + return r + +-- | Memoize the result of a computation for a certain time. A string 'key' is used to index the result +-- +-- The Int parameter is the timeout, in second after the last evaluation, after which the cached value will be discarded and the expression will be evaluated again if demanded +-- . Time == 0 means no timeout +cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int -> m a -> m a +cachedByKey key time f = cached time (\_ -> f) key + +cachedByKeySTM :: (Typeable a, Executable m) => String -> Int -> m a -> STM a +cachedByKeySTM key time f = cachedSTM time (\_ -> f) key + +-- Flush the cached object indexed by the key +flushCached :: String -> IO () +flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k -- !> "flushCached" + +-- | a pure version of cached +cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b +cachedp f k = execute $ cached 0 (\x -> Identity $ f x) k + +--testmemo= do +-- let f x = "hi"++x !> "exec1" +-- let f1 x= "h0"++x !> "exec2" +-- let beacon=1 +-- let beacon2=2 +-- print $ cachedp f (addrStr "sfs") +-- print $ cachedp f (addrStr "sds") +-- print $ cachedp f1 (addrStr "ssdfddd") +-- print $ cachedp f1 (addrStr "sss") + + diff --git a/TCache.cabal b/TCache.cabal --- a/TCache.cabal +++ b/TCache.cabal @@ -1,85 +1,85 @@ -name: TCache -version: 0.12.0 -cabal-version: >= 1.6 -build-type: Simple -license: BSD3 -license-file: LICENSE -maintainer: agocorona@gmail.com -synopsis: A Transactional cache with user-defined persistence -description: TCache is a transactional cache with configurable persitence. It allows conventional - STM transactions for objects that syncronize with their user-defined storages. - State in memory and into permanent storage is transactionally coherent. - . - It has interface defined for Amazon WS and Yesod Persistent backends defined in tcache- - packages. - Persistent is a multi-backend interface for SQL and non SQL databases such in Mongo-db - . - The package implements serializable STM references, access by key and by record field value, triggers, - full text and field indexation, default serialization and a query language based on record fields - . - Since the STM references can be included in data structures and serialized, this is right - for graph databases and other NoSQL databases. - . - 0.12.0 space in index data in indexQuery.hs and IndexText.hs triggered errors in the AWS backend. - The space has been changed by '-'. So rename the "index *" files in the TCache folder - in order to be recognized. - . - 0.11.0.0 added setIndexParsist to define persistence for indexes by type. started the addition of readDBRefs, readResources and so on for simultaneous read, writes and deletes of - objects of the same type. - . - 0.10.2.0 Added setDefaultPersist and modified the signature of setPersist in Data.TCache.DefaultPersistence. - Fixed issues with ghc 7.6.3 - . - 0.10 version add memoization and a persistent and transactional collection/queue. - . - 0.10.0.8 subversion add cachedByKeySTM - . - 0.10.0.9 fixed an error in clearSyncChacheProc and SynWrite Asyncronous that checked the cache continuously - . - See "Data.TCache" for details - . - In this release: - . - Dropped Data.Hashtable (deprecated). Now it uses the package hashtables - - -category: Data, Database -author: Alberto Gómez Corona -tested-with: GHC ==7.0.3 -data-dir: "" -extra-source-files: demos/DBRef.hs - demos/IndexQuery.hs - demos/IndexText.hs - demos/basicSample.hs - demos/caching.hs - demos/triggerRelational.lhs - demos/memoization.hs - demos/DBRef.hs - -source-repository head - type: git - location: https://github.com/agocorona/TCache - -library - build-depends: base >=4 && <5, bytestring -any, - containers >=0.1.0.1, directory >=1.0, old-time >=1.0, - stm -any, text -any, mtl -any, hashtables, - RefSerialize -any - - - - exposed-modules: Data.TCache Data.TCache.DefaultPersistence, - Data.TCache.Defs Data.TCache.IResource Data.TCache.IndexQuery - Data.TCache.IndexText Data.TCache.Memoization Data.TCache.Triggers - Data.Persistent.Collection - Data.Persistent.IDynamic - - - - exposed: True - buildable: True - extensions: OverlappingInstances UndecidableInstances - ScopedTypeVariables DeriveDataTypeable - hs-source-dirs: . - other-modules: - +name: TCache +version: 0.12.1 +cabal-version: >= 1.6 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: agocorona@gmail.com +synopsis: A Transactional cache with user-defined persistence +description: TCache is a transactional cache with configurable persitence. It allows conventional + STM transactions for objects that syncronize with their user-defined storages. + State in memory and into permanent storage is transactionally coherent. + . + It has interface defined for Amazon WS and Yesod Persistent backends defined in tcache- + packages. + Persistent is a multi-backend interface for SQL and non SQL databases such in Mongo-db + . + The package implements serializable STM references, access by key and by record field value, triggers, + full text and field indexation, default serialization and a query language based on record fields + . + Since the STM references can be included in data structures and serialized, this is right + for graph databases and other NoSQL databases. + . + 0.12.0 space in index data in indexQuery.hs and IndexText.hs triggered errors in the AWS backend. + The space has been changed by '-'. So rename the "index *" files in the TCache folder + in order to be recognized. + . + 0.11.0.0 added setIndexParsist to define persistence for indexes by type. started the addition of readDBRefs, readResources and so on for simultaneous read, writes and deletes of + objects of the same type. + . + 0.10.2.0 Added setDefaultPersist and modified the signature of setPersist in Data.TCache.DefaultPersistence. + Fixed issues with ghc 7.6.3 + . + 0.10 version add memoization and a persistent and transactional collection/queue. + . + 0.10.0.8 subversion add cachedByKeySTM + . + 0.10.0.9 fixed an error in clearSyncChacheProc and SynWrite Asyncronous that checked the cache continuously + . + See "Data.TCache" for details + . + In this release: + . + Dropped Data.Hashtable (deprecated). Now it uses the package hashtables + + +category: Data, Database +author: Alberto Gómez Corona +tested-with: GHC ==7.0.3 +data-dir: "" +extra-source-files: demos/DBRef.hs + demos/IndexQuery.hs + demos/IndexText.hs + demos/basicSample.hs + demos/caching.hs + demos/triggerRelational.lhs + demos/memoization.hs + demos/DBRef.hs + +source-repository head + type: git + location: https://github.com/agocorona/TCache + +library + build-depends: base >=4 && <5, bytestring -any, + containers >=0.1.0.1, directory >=1.0, old-time >=1.0, + stm -any, text -any, mtl -any, hashtables, + RefSerialize >= 0.4.0 + + + + exposed-modules: Data.TCache Data.TCache.DefaultPersistence, + Data.TCache.Defs Data.TCache.IResource Data.TCache.IndexQuery + Data.TCache.IndexText Data.TCache.Memoization Data.TCache.Triggers + Data.Persistent.Collection + Data.Persistent.IDynamic + + + + exposed: True + buildable: True + extensions: OverlappingInstances UndecidableInstances + ScopedTypeVariables DeriveDataTypeable + hs-source-dirs: . + other-modules: + diff --git a/demos/memoization.hs b/demos/memoization.hs --- a/demos/memoization.hs +++ b/demos/memoization.hs @@ -6,7 +6,7 @@ main= do - cachedByKey "" 4 f >>= print + cachedByKey "key" 4 f >>= print threadDelay 1000000 main