diff --git a/Data/TCache.hs b/Data/TCache.hs --- a/Data/TCache.hs +++ b/Data/TCache.hs @@ -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 diff --git a/Data/TCache/DefaultPersistence.hs b/Data/TCache/DefaultPersistence.hs --- a/Data/TCache/DefaultPersistence.hs +++ b/Data/TCache/DefaultPersistence.hs @@ -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() diff --git a/Data/TCache/IndexText.hs b/Data/TCache/IndexText.hs --- a/Data/TCache/IndexText.hs +++ b/Data/TCache/IndexText.hs @@ -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) - diff --git a/TCache.cabal b/TCache.cabal --- a/TCache.cabal +++ b/TCache.cabal @@ -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: diff --git a/demos/DBRef.hs b/demos/DBRef.hs new file mode 100644 --- /dev/null +++ b/demos/DBRef.hs @@ -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 + + + diff --git a/demos/DynamicSample.hs b/demos/DynamicSample.hs new file mode 100644 --- /dev/null +++ b/demos/DynamicSample.hs @@ -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 + + diff --git a/demos/IndexQuery.hs b/demos/IndexQuery.hs new file mode 100644 --- /dev/null +++ b/demos/IndexQuery.hs @@ -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 diff --git a/demos/basicSample.hs b/demos/basicSample.hs new file mode 100644 --- /dev/null +++ b/demos/basicSample.hs @@ -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 diff --git a/demos/caching.hs b/demos/caching.hs new file mode 100644 --- /dev/null +++ b/demos/caching.hs @@ -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 + diff --git a/demos/triggerRelational.lhs b/demos/triggerRelational.lhs new file mode 100644 --- /dev/null +++ b/demos/triggerRelational.lhs @@ -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 +