TCache 0.9 → 0.9.0.1
raw patch · 10 files changed
+604/−90 lines, 10 files
Files
- Data/TCache.hs +67/−46
- Data/TCache/DefaultPersistence.hs +25/−21
- Data/TCache/IndexText.hs +33/−18
- TCache.cabal +15/−5
- demos/DBRef.hs +119/−0
- demos/DynamicSample.hs +65/−0
- demos/IndexQuery.hs +35/−0
- demos/basicSample.hs +95/−0
- demos/caching.hs +56/−0
- demos/triggerRelational.lhs +94/−0
Data/TCache.hs view
@@ -264,12 +264,12 @@ import System.Time import System.Mem import System.Mem.Weak---import Debug.Trace import Control.Concurrent.MVar -+import Control.Exception(catch, throw)+--import Debug.Trace ---debug = flip trace+--(!>) = flip trace -- there are two references to the DBRef here -- The Maybe one keeps it alive until the cache releases it for *Resources@@ -338,13 +338,17 @@ -- | 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= do+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]+ applyTriggers [dbref] [Just x] -- !> ("writeDBRef "++ key) t <- unsafeIOToSTM timeInteger writeTVar tv $ Exist $ Elem x t t return()@@ -381,14 +385,14 @@ getDBRef key= unsafePerformIO $! getDBRef1 $! key where getDBRef1 :: (Typeable a, IResource a) => String -> IO (DBRef a) getDBRef1 key= do- (cache,_) <- readIORef refcache+ (cache,_) <- readIORef refcache -- !> ("getDBRef "++ key) r <- H.lookup cache key case r of Just (CacheElem _ w) -> do mr <- deRefWeak w case mr of- Just dbref@(DBRef _ tv) -> return $ castErr dbref- Nothing -> finalize w >> getDBRef1 key -- the weak pointer hasn executed his finalizer+ Just dbref@(DBRef _ tv) -> return $! castErr dbref+ Nothing -> finalize w >> getDBRef1 key -- the weak pointer has not executed his finalizer Nothing -> do tv<- newTVarIO NotRead@@ -423,21 +427,21 @@ -} --- get a single DBRef if exist -mDBRefIO - :: (IResource a, Typeable a) - => String -- ^ the list of partial object definitions for which keyResource can be extracted - -> IO (Either Ht (DBRef a)) -- ^ The TVars that contain such objects-mDBRefIO k= do - (cache,_) <- readIORef refcache- r <- H.lookup cache k- case r of- Just (CacheElem _ w) -> do- mr <- deRefWeak w- case mr of- Just dbref -> return . Right $ castErr dbref- Nothing -> finalize w >> mDBRefIO k- Nothing -> return $ Left cache +---- 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 @@ -446,24 +450,32 @@ -- If an object with the same key already exists, it is returned as is -- If not, the reference is created with the new value. -- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined- -newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) ++newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) newDBRef x = do- let key= keyResource x - mdbref <- unsafeIOToSTM $ mDBRefIO key - case mdbref of - Right dbref -> return dbref- Left cache -> do - t <- unsafeIOToSTM timeInteger - tv <- newTVar DoNotExist- let dbref= DBRef key tv- (cache,_) <- unsafeIOToSTM $ readIORef refcache- applyTriggers [dbref] [Just x]- writeTVar tv . Exist $ Elem x t t - unsafeIOToSTM $ do- w <- mkWeakPtr dbref . Just $ deleteFromCache dbref - H.update cache key ( CacheElem Nothing w) - return dbref + let ref= getDBRef $ keyResource x+ mr <- readDBRef ref+ case mr of+ Nothing -> writeDBRef ref x >> return ref+ Just r -> return ref+ +--newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) +--newDBRef x = do+-- let key= keyResource x +-- mdbref <- unsafeIOToSTM $ mDBRefIO key +-- case mdbref of +-- Right dbref -> return dbref+-- Left cache -> do +-- t <- unsafeIOToSTM timeInteger +-- tv <- newTVar DoNotExist+-- let dbref= DBRef key tv+-- (cache,_) <- unsafeIOToSTM $ readIORef refcache+-- applyTriggers [dbref] [Just x]+-- writeTVar tv . Exist $ Elem x t t +-- unsafeIOToSTM $ do+-- w <- mkWeakPtr dbref . Just $ deleteFromCache dbref +-- H.update cache key ( CacheElem Nothing w) +-- return dbref -- | delete the content of the DBRef form the cache and from permanent storage delDBRef :: (IResource a, Typeable a) => DBRef a -> STM()@@ -516,6 +528,10 @@ -- * '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: the values to be written must be fully evaluated. Delayed evaluations at+-- serialization time can cause inconsistencies in the database.+-- In future releases this will be enforced. 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. @@ -603,7 +619,7 @@ Just (CacheElem _ w) -> do mr <- unsafeIOToSTM $ deRefWeak w case mr of- Just dbref -> return . Just $ castErr dbref+ Just dbref -> return . Just $! castErr dbref Nothing -> unsafeIOToSTM (finalize w) >> takeDBRef cache flags x Nothing -> do safeIOToSTM $ readToCache flags cache keyr -- unsafeIOToSTM $ readResourceByKey keyr @@ -789,8 +805,8 @@ save tosave = do (pre, post) <- readIORef refConditions - pre- mapM (\(Filtered x) -> writeResource x) tosave + pre -- !> (concatMap (\(Filtered x) -> keyResource x)tosave)+ mapM (\(Filtered x) -> writeResource x) tosave post @@ -814,7 +830,7 @@ Exist (Elem r _ modTime) -> if (modTime >= lastSave) then filter1 (Filtered r:sav) tofilter (n+1) rest- else filter1 sav tofilter (n+1) rest + else filter1 sav tofilter (n+1) rest -- !> ("rejected->" ++ keyResource r) _ -> filter1 sav tofilter (n+1) rest @@ -823,8 +839,13 @@ safeIOToSTM :: IO a -> STM a safeIOToSTM req= unsafeIOToSTM $ do tv <- newEmptyMVar- forkIO $ req >>= putMVar tv- takeMVar tv+ 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
Data/TCache/DefaultPersistence.hs view
@@ -1,6 +1,7 @@ {- | -This module provides default persistence , understood as retrievong and storing thje object in serialized blobs+This module provides default persistence , understood as retrievong and storing the object in serialized blobs+but also to compose a SQL string and write it to a databases. for Indexable and serializable instances. The user can define it with setPersist. If the user does not set it, persistence in files is used. @@ -9,8 +10,9 @@ {-# LANGUAGE FlexibleInstances, UndecidableInstances , MultiParamTypeClasses, FunctionalDependencies , ExistentialQuantification+ , ScopedTypeVariables #-}-module Data.TCache.DefaultPersistence(Indexable(..),Serializable(..),setPersist,Persist(..)) where+module Data.TCache.DefaultPersistence(Indexable(..),Serializable(..),Persist(..)) where import Data.TCache.IResource@@ -30,7 +32,7 @@ import Debug.Trace ---debug a b = trace b a+a !> b = trace b a {- | Indexable is an utility class used to derive instances of IResource @@ -70,11 +72,15 @@ > serialize = show > deserialize= read++Since write and read to disk of to/from the cache must not be very often+The performance of serialization is not critical. -} class Serializable a {-serialFormat-} | a -> {-serialFormat-} where serialize :: a -> B.ByteString --serialFormat deserialize :: {-serialFormat-} B.ByteString -> a-+ setPersist :: a -> Persist+ setPersist _= defaultPersist {- instance (Show a, Read a)=> Serializable a where serialize= show@@ -93,39 +99,33 @@ ,write= defaultWrite ,delete= defaultDelete} --persist :: IORef Persist-persist = unsafePerformIO $ newIORef $ defaultPersist---- | set an alternative persistence for Indexable and Serializable objects-setPersist :: Persist -> IO ()-setPersist p = writeIORef persist p-+getPersist x= return (setPersist x)+ `Exception.catch` (\(e:: SomeException) -> error "setPersist must not depend on the type, not the value of the parameter: " ) instance (Typeable a, Indexable a, Serializable a ) => IResource a where keyResource = key writeResource s=do- Persist _ f _ <- readIORef persist+ Persist _ f _ <- getPersist s f (defPath s ++ key s) $ castErr $ serialize s readResourceByKey k= iox where iox= do- Persist f _ _ <- readIORef persist+ Persist f _ _ <- getPersist x f file >>= return . fmap deserialize . castErr where file= defPath x ++ k x= undefined `asTypeOf` (fromJust $ unsafePerformIO iox) delResource s= do- Persist _ _ f <- readIORef persist+ Persist _ _ f <- getPersist s f $ defPath s ++ key s defaultReadByKey :: String-> IO (Maybe B.ByteString) -defaultReadByKey k= iox+defaultReadByKey k= iox -- !> "defaultReadByKey" where iox = handle handler $ do s <- readFileStrict k @@ -138,22 +138,26 @@ | isDoesNotExistError e = return Nothing | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e) then- error $ ( "readResource: " ++ show e) ++ " defPath and/or keyResource are not suitable for a file path"+ error $ "readResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path" else defaultReadByKey k defaultWrite :: String-> B.ByteString -> IO()-defaultWrite filename x= safeWrite filename x --`debug` ("write "++filename)-safeWrite filename str= handle handler $ B.writeFile filename str+defaultWrite filename x= safeWrite filename x+safeWrite filename str= handle handler $ B.writeFile filename str -- !> ("write "++filename) where handler e-- (e :: IOError) | isDoesNotExistError e=do createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename --maybe the path does not exist safeWrite filename str - | otherwise =do- --phPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" ++ | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e)+ then+ error $ "writeResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path" + else do+ hPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" safeWrite filename str defaultDelete :: String -> IO()
Data/TCache/IndexText.hs view
@@ -3,10 +3,13 @@ , FlexibleInstances , UndecidableInstances , MultiParamTypeClasses #-}-module Data.TCache.IndexText(indexText, contains) where+module Data.TCache.IndexText(indexText, indexList, contains, containsElem) where -{-Implements full text indexation (`indexText`) and text search(`contains`), as an addition to+{- | Implements full text indexation (`indexText`) and text search(`contains`), as an addition to the query language implemented in `Data.TCache.IndexQuery`+it also can index the lists of elements in a field (with `indexList`)+so that it is possible to ask for the registers that contains a given element+in the given field (with `containsElem`) An example: @@ -49,6 +52,7 @@ import Data.Char import Control.Concurrent(threadDelay) import Data.ByteString.Lazy.Char8(pack, unpack)+import Debug.Trace data IndexText= IndexText { fieldType :: !String@@ -107,19 +111,26 @@ => (a -> b) -- ^ field to index -> (b -> T.Text) -- ^ method to convert the field content to Text (for example `pack` in case of String fields). This permits to index non Textual fields -> IO ()-indexText sel convert= addTrigger (indext sel refIndex convert) where- [t1,t2]= typeRepArgs $! typeOf sel- t= show t1 ++ show t2- refIndex= getDBRef . key $ IndexText t u u u u where u= undefined- indext :: (IResource a, Typeable a) => (a -> b) -> DBRef IndexText -> (b -> T.Text) -> DBRef a -> Maybe a -> STM()- indext sel refIndex convert dbref mreg= f1 -- unsafeIOToSTM $! f+indexText sel convert= addTrigger (indext sel (words1 . convert)) where++indexList+ :: (IResource a, Typeable a, Typeable b)+ => (a -> b) -- ^ field to index+ -> (b -> [T.Text]) -- ^ method to convert the field content to Text (for example `pack` in case of String fields). This permits to index non Textual fields+ -> IO ()+indexList sel convert= addTrigger (indext sel convert) where+++indext :: (IResource a, Typeable a,Typeable b)+ => (a -> b) -> (b -> [T.Text]) -> DBRef a -> Maybe a -> STM()+indext sel convert dbref mreg= f1 -- unsafeIOToSTM $! f where f= forkIO (atomically f1) >> return() f1= do moldreg <- readDBRef dbref case ( moldreg, mreg) of- (Nothing, Just reg) -> mapM_ (add refIndex t (keyResource reg)) . words1 . convert $ sel reg- (Just oldreg, Nothing) -> mapM_ (del refIndex t (keyResource oldreg)) . words1 . convert $ sel oldreg+ (Nothing, Just reg) -> mapM_ (add refIndex t (keyResource reg)) . convert $ sel reg+ (Just oldreg, Nothing) -> mapM_ (del refIndex t (keyResource oldreg)) . convert $ sel oldreg (Just oldreg, Just reg) -> do st <- unsafeIOToSTM $ makeStableName $ sel oldreg -- test if field st' <- unsafeIOToSTM $ makeStableName $ sel reg -- has changed@@ -127,16 +138,21 @@ then return () else do let key= keyResource reg- let wrds = words1 . convert $ sel oldreg- let wrds'= words1 . convert $ sel reg+ let wrds = convert $ sel oldreg+ let wrds'= convert $ sel reg let new= wrds' \\ wrds let old= wrds \\ wrds' mapM (del refIndex t key) old mapM (add refIndex t key) new return()+ where+ [t1,t2]= typeRepArgs $! typeOf sel+ t= show t1 ++ show t2+ refIndex= trace "gettig ref" getDBRef . key $ IndexText t u u u u where u= undefined -search :: (IResource a, Typeable a, Typeable b) => (a -> b) -> T.Text -> STM [DBRef a]-search sel w = do+containsElem :: (IResource a, Typeable a, Typeable b) => (a -> b) -> String -> STM [DBRef a]+containsElem sel wstr = do+ let w= T.pack wstr let [t1, t2]= typeRepArgs $! typeOf sel let t= show t1 ++ show t2 let u= undefined@@ -160,13 +176,12 @@ =>( a -> b) -- ^ field to search in -> String -- ^ text to search -> STM [DBRef a]-contains sel str= let text= T.pack str in case T.words text of+contains sel str= case words str of [] -> return []- [w] -> search sel w+ [w] -> containsElem sel w ws -> do- let rs = map (search sel) $ filter (\t -> T.length t >2) ws+ let rs = map (containsElem sel) $ filter (\t -> length t >2) ws foldl (.&&.) (head rs) (tail rs)-
TCache.cabal view
@@ -1,14 +1,17 @@ name: TCache-version: 0.9+version: 0.9.0.1 synopsis: A Transactional cache with user-defined persistence description:-- This version now has full text search. Serialization is now trough byteStrings- TCache is a transactional cache with configurable persitence. It allows conventional STM transactions for objects that syncronize with their user defined storages. Default persistence in files is provided for testing purposes+ State in memory and into permanent storage is transactionally coherent.++ 0.9.0.1 : Solves a bug when object keys generate invalid filenames. .+ 0.9: This version now has full text search. Serialization is now trough byteStrings++ . This version support the backward compatible stuff, that permits transparent retrievals of objects and transcactions between objects without directly using STM references ('with*Resource(s)' calls), Now it goes in the oposite direction by providing explicit STM persistent@@ -54,4 +57,11 @@ exposed-modules: Data.TCache, Data.TCache.DefaultPersistence , Data.TCache.IndexQuery,Data.TCache.IndexText, Data.TCache.Triggers , Data.TCache.IResource, Data.TCache.Defs-ghc-options: -O2++extra-source-files: demos/basicSample.hs+ demos/caching.hs+ demos/DBRef.hs+ demos/DynamicSample.hs+ demos/IndexQuery.hs+ demos/triggerRelational.lhs+ghc-options:
+ demos/DBRef.hs view
@@ -0,0 +1,119 @@+{-# OPTIONS -XDeriveDataTypeable #-}+module Main where+import Data.TCache+import Data.TCache.FilePersistence+import GHC.Conc+import System.IO.Unsafe+import Data.Typeable+import Debug.Trace+import System.Mem+import System.Mem.Weak++++newtype Other= Other String deriving (Read, Show)++data Company = Company {+ cname :: String+ ,personnel :: [DBRef Emp]+ ,other :: Other}+ deriving (Read, Show,Typeable)++data Emp= Emp{ename :: String, salary :: Float} deriving (Read, Show, Typeable)++instance Indexable Company where+ key Company{cname=name}= name+++instance Indexable Emp where+ key Emp{ename= name}= name+++myCompanyName= "mycompany"++myCompanyRef= unsafePerformIO . atomically $ do++ refEmp1 <- newDBRef Emp{ename= "Emp1", salary= 34000}+ refEmp2 <- newDBRef Emp{ename= "Emp2", salary= 35000}+ refEmp3 <- newDBRef Emp{ename= "Emp3", salary= 54000}+ refEmp4 <- newDBRef Emp{ename= "Emp4", salary= 64000}++ newDBRef $+ Company+ {cname= myCompanyName+ ,personnel= [refEmp1, refEmp2, refEmp3, refEmp4]+ ,other= Other "blah blah blah"}+++-- myCompany= Company myCompanyName [getDBRef "Emp1",getDBRef "Emp2",getDBRef "Emp3"]++++increaseSalaries percent= do+ Just mycompany <- readDBRef myCompanyRef+ mapM_ (increase percent ) $ personnel mycompany+ where+ increase percent ref= do+ Just emp <- readDBRef ref+ writeDBRef ref $ emp{salary= salary emp * factor}+ where+ factor= 1+ percent/ 100++printSalaries ref= do+ Just comp <- atomically $ readDBRef ref+ mapM_ printSalary $ personnel comp+ where+ printSalary ref= atomically (readDBRef ref) >>= print++putMsg msg= putStrLn $ ">>" ++ msg++main= do+ putMsg "DBRefs are cached idexable, serializable, unique-by-key references to objects stored in the cache, mutable under STM transactions"+ putMsg "DBRef's are instances of Show"+ print myCompanyRef+++ let myCompanyRef2= read $ show myCompanyRef :: DBRef Company+ putMsg "DBRefs are identified by the key of the referenced object"+ putMsg "DBRef's are alse instances of read"++ print myCompanyRef2+ putMsg "DBReference's with the same key point to the same data object"+ putMsg "DBRefs can be part of serializable mutable structures"+ putMsg "the referenced object are reloaded transparently on demand in the cache and discarded according with TCache definable policies"+ putMsg "the DBRef load and reload requires a cache lockup, but subsequient accesses does not. so performance is almost like TVars and way better that the *Resource* primitives"+ atomically (readDBRef myCompanyRef) >>= print+ atomically (readDBRef myCompanyRef2) >>= print++ putMsg "Before salary increase, the company personnel is accessed with the second reference"+ printSalaries myCompanyRef2+ putMsg "atomically increase the salaries of all the personel"+ atomically $ increaseSalaries 10+ putMsg "after the increase"+ printSalaries myCompanyRef2++ let emp3ref= getDBRef "Emp3"+ putMsg "tch tch, this bad boy does not deserve his salary"+ Just emp3 <- atomically $ readDBRef emp3ref+ print emp3+ atomically $ writeDBRef emp3ref $ emp3{salary= 10000}++ putMsg "so the complete list of company salaries are..."+ printSalaries myCompanyRef+ syncCache -- use it if you want to save all the changes. (or, else, clearSyncCache)++ putStrLn "checking race condition on cache cleaning"++ let emp1= Emp{ename="Emp1"}+ let key= keyResource emp1+ let remp1 = getDBRef key+ Just emp1 <- atomically $ readDBRef remp1+ atomically $ flushDBRef remp1+ let remp1'= getDBRef key+ atomically $ writeDBRef remp1' $ emp1{salary=0}++ putStrLn "must reflect the salary 0 for emp1"+ printSalaries myCompanyRef2+++
+ demos/DynamicSample.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS -XTypeSynonymInstances #-} +-- XTypeSynonymInstances added only to permit IResource instances for Strings +module Main where+import Data.TCache+import Data.TCache.FilePersistence +import Data.Typeable + +{------------- tests--------- +example of IDynamic usage. + +-} + +--very simple data: +--two objects with two different datatypes: Int and String + +instance Indexable Int where + key x= show x + + + + +instance Indexable String where + key x= take 2 x + + + + +main= do + putStrLn "see the code to know the meaning of he results"++ -- NOTE registerType no longer needed+ + + let x= 1:: Int++ -- now *Resources primitives suppont different datatypes+ -- without the need of Data.Dynamic + withResources [] $ const [x]+ withResources [] $ const ["hola"] --resources creation + + syncCache + + res <- getResource x + print res + + res <- getResource "ho" + print res ++ -- to use heterogeneous data in the same transaction,+ -- use DBRef's:+ s <- atomically $ do+ let refInt = getDBRef $ keyResource x :: DBRef Int+ refString = getDBRef $ keyResource "ho" :: DBRef String+ i <- readDBRef refInt+ writeDBRef refString $ "hola, the retrieved value of x is " ++ show i+ s <- readDBRef refString+ return s++ print s++ -- however, retrieval of data with the incorrect type will generate an exception:+ + syncCache + +
+ demos/IndexQuery.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Main where+import Data.TCache+import Data.TCache.IndexQuery+import Data.TCache.FilePersistence+import Debug.Trace++import Data.Typeable+++data Person= Person {pname :: String} deriving (Show, Read, Eq, Typeable)++data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)++instance Indexable Person where key Person{pname= n} = "Person " ++ n+instance Indexable Car where key Car{cname= n} = "Car " ++ n+++main = do++ index owner+ index pname+ index cname++ bruce <- atomically $ newDBRef $ Person "bruce"+ atomically $ mapM_ newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"]++ r <- atomically $ cname .>=. "Bat Mobile"+ print r++ r <- atomically $ select (cname, owner) $ (owner .==. bruce) .&&. (cname .>=. "Bat Mobile")+ print r+++ --syncCache
+ demos/basicSample.hs view
@@ -0,0 +1,95 @@+ module Main where+-------------------------------------------------+-- A example of Transactional cache usage (TCache.hs)+-- (Something like the Java Hibernate)+-- Author: Alberto Gómez Corona Nov 2006+-- Language: Haskell+-- Terms of use: you can do whatever you want+-- with this code as long as you keep this notice+------------------------------------------------+++import Data.TCache++import Control.Concurrent+import Debug.Trace++debug a b= trace b a++-- The data elements to be used in the example: A user will repeatedly buy Items.++data Data= User{uname::String, uid::String, spent:: Int} |+ Item{iname::String, iid::String, price::Int, stock::Int}++ deriving (Read, Show)+++-- The mappings between the cache and the phisical storage are defined by the interface IResource+-- to extract the unique key,+-- to serializa to string+-- to deserialize from string+-- key prefix (or , if use "/", directory where to store the resource if default write is to be used)+-- to read the resource from the physical storage, (optional, default in files)+-- to store it (optional, default from file)+-- to delete the resource from the physical storage. (optional. Default provided)++++instance Indexable Data where+ key User{uid=id}= id+ key Item{iid=id}= id++ -- other definable methods: readResource, writeResource delResource. here the default persistence in files are used++-- buy is the operation to be performed in the example++--withResources gets a partial definition of each resource necessary for extracting the key,+--fill all the rest of the data structures (if found ) and return a list of Maybe Data.+--BuyIt is part of the domain problem. it receive this list and generates a new list of+--data objects that are updated in the cache. buyIt is executed atomically.+++user `buy` item= withResources[user,item] buyIt+ where+ buyIt[Just us,Just it]+ | stock it > 0= [us',it'] `debug` "john buy a PC"+ | 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 does not exist"+++main= do+ -- create resources (acces no resources and return two new Data objects defined in items)+ withResources[]items++ --11 PCs are charged to the John´s account in paralel, to show transactionality+ --because there are only 10 PCs in stock, the last thread must return an error++ for 11 $ forkIO $ User{uid="U12345"} `buy` Item{iid="I54321"}++ --wait 1 seconds+ threadDelay 1000000++ [us,it] <- getResources [User{uid="U12345"}, Item{iid="I54321"}]++ putStrLn $ "user data=" ++ show us+ putStrLn $ "item data=" ++ show it++ -- write the cache content in a persistent store (invoque writeResource for each resource)+ -- in a real application clearSyncCacheProc can be used instead to adjust size and write the cache periodically++ syncCache (refcache :: Cache Data)++ -- the files have been created. the files U12345 and I54321 must contain the result of the 11 iterations++ where+ items _=+ [User "John" "U12345" 0+ ,Item "PC" "I54321" 6000 10]++ for 0 _ = return ()+ for n f= f >> for (n-1) f
+ demos/caching.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Main where+-------------------------------------------------+-- TCache example++------------------------------------------------++import Data.TCache+import Data.TCache.FilePersistence+import Control.Concurrent+import Debug.Trace+import Data.Typeable+debug a b= trace b a++-- The data elements to be used in the example++data Data= Data Int Int deriving (Read, Show, Typeable)++++instance Indexable Data where+ key (Data i _)= show i+ defPath _ = "cacheData/" -- directory where the data is stored.++ -- other definable methods: readResource, writeResource delResource. here the default persistence in files are used++++main= do++ putStrLn "see the source code of this example"+ putStrLn "This program test the caching and cleaning and re-retrieval and update of the cache"++ putStrLn "asyncronous write every 10 seconds, 100 elems max cache size"+ putStrLn "default policy (defaultCheck) for clearing the cache is to reduce the cache to half of max sixe when size exceeds the max"++ putStrLn ""+ putStrLn "create resources"+ putStrLn " (acces no resources and return two new Data objects defined in items)"+ withResources[] $ const[Data i 0 | i <- [1..200]]++ putStrLn ""+ putStrLn $ "after 10 seconds, 200 files have been created in the folder: " ++ defPath ( undefined :: Data)+ putStrLn "wait 10 seconds to let the next write cycle to enter (every 10 seconds, set in clearSyncCacheProc)"+ clearSyncCacheProc 10 defaultCheck 100++ putStrLn "because 200 exceeds the maximum cache size (100) defaultCheck will discard the 150 older elems to reduce the cache to a half"+ putStrLn "This is the behaviour defined in defaultCheck."+ threadDelay 20000000+ putStrLn " update every element, included the discarded ones"+ withResources [Data i undefined | i <- [1..200]] $+ \ds -> [ Data i (n+1) | Just(Data i n) <- ds]++ putStrLn $"wait for the next cycle of file update. The files must contain 1 instead o 0 (Data n 1) in the folder "++ defPath ( undefined :: Data)+ threadDelay 20000000+
+ demos/triggerRelational.lhs view
@@ -0,0 +1,94 @@+example of trigger and DBRef usage to maintain data relations+This is an example of trigger usage, but is a bad practice+For a better implementation of two way references, with this same example+ see indexQuery.hs that uses Data.TCache.IndexQuery++mimic the example taken from http://docs.yesodweb.com/book/persistent++implements one to many relationship with the use of DBref's and triggers to maintain+the relationships.+++> {-# LANGUAGE DeriveDataTypeable #-}+> module Main where+> import Data.TCache+> import Data.TCache.Triggers+> import Data.TCache.FilePersistence+> import Control.Concurrent.STM+> import Data.List (delete,nub)+> import Data.Typeable+> import Control.Monad(when)+> import Debug.Trace+> import GHC.Conc+++> data Person= Person{ pname :: String, cars :: [DBRef Car]} deriving (Show, Read, Typeable)+> data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)++> instance Indexable Person where key Person{pname=n} = "Person " ++ n+> instance Indexable Car where key Car{cname= n} = "Car " ++ n++every time a car is added, or deleted the owner's list is updated+this is done by the addCar trigger++> addCar pcar (Just(car@(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+>+> insert= withResources [] . const++gives:++ >main1+ >2+ >Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]}+- -+++the car can be used, and the modification of the car register can come from+an owner change. The deletion of the car from the previous owner list can be+done because the trigger hook is called before the update, so+the DBRef maintain the old value.++So a better version of addCar is:+++> betterAddCar pcar car@(Car powner _ ) = do+> updateNeeded <- processOldOwner powner pcar -- inserted+> when updateNeeded $ addToOwner powner pcar+> where+> processOldOwner powner pcar= do+> mc <- readDBRef pcar+> case mc of+> Nothing -> return True+> Just Car{owner= pother} ->+> if pother== powner+> then return False -- is unchanged, not necesary to update+> else do+> deleteOwner pother pcar+> return True+