diff --git a/Data/TCache.hs b/Data/TCache.hs --- a/Data/TCache.hs +++ b/Data/TCache.hs @@ -5,30 +5,26 @@ STM transactions with objects thar syncronize sincromous or asyncronously with their user defined storages. Default persistence in files is provided for testing purposes -In this release some stuff has been supressed without losing functionality. Dynamic interfaces -are not needed since TCache can handle heterogeneous data. -The new things in this release, besides the backward compatible stuf are: - - TCache now implements. ''DBRef' 's . They are persistent STM references with a traditional 'readDBRef', 'writeDBRef' Haskell interface. -simitar to TVars, but with aded. persistence -Additionally, because DBRefs are serializable, they can be embeded in serializable registers. + TCache implements ''DBRef' 's . They are persistent STM references with a traditional 'readDBRef', 'writeDBRef' Haskell interface. +simitar to TVars ('newDBRef', 'readDBRef', 'writeDBRef' etc) but with added. persistence +. DBRefs are serializable, so they can be stored and retrieved. See some examples below Because they are references,they point to other serializable registers. This permits persistent mutable Inter-object relations -Triggers are user defined hooks that are called back on register updates. That can be used for: - - - ease the work of maintain actualized the inter-object relations +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. +See examples below. - - permit more higuer level and customizable accesses +Triggers in "Data.TCache.Triggers" are user defined hooks that are called back on register updates. That can be used for: + "Data.TCache.IndexQuery" implements an straighforwards pure haskell type safe query language based on register field relations. This module must be imported separately. - see "Data.TCache.IndexQuery" for further information -The file persistence is now more reliable, and the embedded IO reads inside STM transactions are safe. +"Data.TCache.IndexText" add full text search and content search to the qhery language -To ease the implementation of other user-defined persistence, "Data.TCache.FIlePersistence" must be imported - for deriving file persistence instances +"Data.TCache.DefaultPersistence" define instances for key definition, serialization +and persistence, and default file persistence. The file persistence is now more reliable, and the embedded IO reads inside STM transactions are safe. -} @@ -42,7 +38,7 @@ atomically ,STM --- * operations with cached database references +-- * 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, @@ -151,8 +147,8 @@ 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} +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 @@ -230,7 +226,7 @@ ,addTrigger --- * cache control +-- * Cache control ,flushDBRef ,flushAll ,Cache @@ -243,7 +239,7 @@ ,numElems ,clearSyncCacheProc ,defaultCheck --- * auxiliary file operations used for default persistence in files. + ) where @@ -266,10 +262,10 @@ import System.Mem.Weak import Control.Concurrent.MVar -import Control.Exception(catch, throw) -import Debug.Trace +import Control.Exception(catch, throw,evaluate) -(!>) = flip trace +--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 @@ -312,7 +308,7 @@ deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO () deleteFromCache (DBRef k tv)= do (cache, _) <- readIORef refcache - H.delete cache k + H.delete cache k -- !> ("delete " ++ k) -- | return the reference value. If it is not in the cache, it is fetched @@ -350,7 +346,7 @@ else do applyTriggers [dbref] [Just x] t <- unsafeIOToSTM timeInteger - writeTVar tv $ Exist $ Elem x t t !> ("writeDBRef "++ key) + writeTVar tv $ Exist $ Elem x t t -- !> ("writeDBRef "++ key) return() @@ -381,6 +377,7 @@ -- 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) @@ -396,11 +393,11 @@ Nothing -> do tv<- newTVarIO NotRead - let dbref= DBRef key tv + dbref <- evaluate $ DBRef key tv w <- mkWeakPtr dbref . Just $ deleteFromCache dbref H.update cache key (CacheElem Nothing w) return dbref - + {- | Create the object passed as parameter (if it does not exist) and -- return its reference in the IO monad. -- If an object with the same key already exists, it is returned as is @@ -450,6 +447,7 @@ -- 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' newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) newDBRef x = do @@ -457,8 +455,8 @@ mr <- readDBRef ref case mr of - Nothing -> writeDBRef ref x >> return ref !> " write" - Just r -> return ref !> " non write" + 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 @@ -530,24 +528,23 @@ -- -- * '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. +-- 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 + mtrs <- takeDBRefs rs cache AddToHash mrs <- mapM mreadDBRef mtrs case f mrs of Retry -> retry Resources as ds r -> do - applyTriggers (map (getDBRef . keyResource) as) (map Just as) applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing `asTypeOf` (Just(head ds)))) - delListFromHash cache ds + delListFromHash cache ds releaseTPVars as cache safeIOToSTM $ bracket @@ -610,7 +607,7 @@ 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 @@ -621,12 +618,12 @@ mr <- unsafeIOToSTM $ deRefWeak w case mr of Just dbref -> return . Just $! castErr dbref - Nothing -> unsafeIOToSTM (finalize w) >> takeDBRef cache flags x + Nothing -> unsafeIOToSTM (finalize w) >> takeDBRef cache flags x Nothing -> do safeIOToSTM $ readToCache flags cache keyr -- unsafeIOToSTM $ readResourceByKey keyr - where - readToCache flags cache key= do + where + readToCache flags cache key= do mr <- readResourceByKey key case mr of Nothing -> return Nothing @@ -636,11 +633,11 @@ case flags of NoAddToHash -> return . Just $ DBRef key tvr AddToHash -> do - let dbref= DBRef key tvr + dbref <- evaluate $ DBRef key tvr w <- mkWeakPtr dbref . Just $ deleteFromCache dbref H.update cache key (CacheElem (Just dbref) w) return $ Just dbref - + -- !> ("readToCache "++ key) @@ -653,24 +650,27 @@ 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 + Just (CacheElem _ w) -> do mr <- unsafeIOToSTM $ deRefWeak w case mr of Nothing -> unsafeIOToSTM (finalize w) >> releaseTPVar cache r - Just (DBRef key tv) -> do + 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 . Exist $ Elem r ti ti - let dbref= DBRef keyr tvr + 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 $ deleteFromCache dbref unsafeIOToSTM $ H.update cache keyr (CacheElem (Just dbref) w)-- accesed and modified XXX return () @@ -693,8 +693,10 @@ Just (CacheElem _ w) -> do mr <- unsafeIOToSTM $ deRefWeak w case mr of - Just (DBRef _ tv) -> writeTVar tv DoNotExist - Nothing -> unsafeIOToSTM (finalize w) >> del x + Just dbref@(DBRef _ tv) -> do + writeTVar tv DoNotExist + Nothing -> do + unsafeIOToSTM (finalize w) >> del x @@ -706,7 +708,7 @@ -- | Start the thread that periodically call 'clearSyncCache' to clean and writes on the persistent storage. -- Otherwise, 'syncCache' must be invoked explicitly or no persistence will exist. -- Cache writes allways save a coherent state -clearSyncCacheProc :: +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 @@ -814,7 +816,7 @@ data Filtered= forall a.(IResource a)=> Filtered a -extract elems lastSave= filter1 [] [] (0::Int) elems +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 diff --git a/Data/TCache/DefaultPersistence.hs b/Data/TCache/DefaultPersistence.hs --- a/Data/TCache/DefaultPersistence.hs +++ b/Data/TCache/DefaultPersistence.hs @@ -1,10 +1,9 @@ {- | -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. - +This module decouples the interface of 'IResource" class in two classes +one for key extraction 'Indexable' and other ('Serializable" for serlalization and persistence +.This last one defines persistence in files as default, but it can be changed +to persistence in databases, for examople. -} {-# LANGUAGE FlexibleInstances, UndecidableInstances @@ -12,7 +11,7 @@ , ExistentialQuantification , ScopedTypeVariables #-} -module Data.TCache.DefaultPersistence(Indexable(..),Serializable(..),Persist(..)) where +module Data.TCache.DefaultPersistence(Indexable(..),Serializable(..),defaultPersist,Persist(..)) where import Data.TCache.IResource @@ -89,9 +88,10 @@ -- deserialize= read --- | +-- | a persist mechanism has to implement these three primitives +-- 'defaultpersist' is the default file persistence data Persist = Persist{ - readByKey :: (String -> IO(Maybe B.ByteString)) -- ^ read + readByKey :: (String -> IO(Maybe B.ByteString)) -- ^ read by key , write :: (String -> B.ByteString -> IO()) -- ^ write , delete :: (String -> IO())} -- ^ delete diff --git a/Data/TCache/IndexQuery.hs b/Data/TCache/IndexQuery.hs --- a/Data/TCache/IndexQuery.hs +++ b/Data/TCache/IndexQuery.hs @@ -98,6 +98,7 @@ class (Read reg, Read a, Show reg, Show a, IResource reg,Typeable reg, Typeable a,Ord a) => Queriable reg a +instance (Read reg, Read a, Show reg, Show a, IResource reg,Typeable reg, Typeable a,Ord a) => Queriable reg a instance (Queriable reg a) => Serializable (Index reg a) where serialize= pack . show diff --git a/Data/TCache/IndexText.hs b/Data/TCache/IndexText.hs --- a/Data/TCache/IndexText.hs +++ b/Data/TCache/IndexText.hs @@ -11,8 +11,9 @@ so that it is possible to ask for the registers that contains a given element in the given field (with `containsElem`) -An example of full text search: +An example of full text search i before and after an update in the text field + @ data Doc= Doc{title, body :: String} deriving (Read,Show, Typeable) instance Indexable Doc where @@ -53,7 +54,7 @@ import Data.Char import Control.Concurrent(threadDelay) import Data.ByteString.Lazy.Char8(pack, unpack) -import Debug.Trace +--import Debug.Trace data IndexText= IndexText { fieldType :: !String @@ -110,14 +111,15 @@ indexText :: (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 + -> (b -> T.Text) -- ^ method to convert the field content to lazy Text (for example `pack` in case of String fields). This permits to index non Textual fields -> IO () indexText sel convert= addTrigger (indext sel (words1 . convert)) where +-- | trigger the indexation of list fields with elements convertible to Text 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 + -> (b -> [T.Text]) -- ^ method to convert a field element to Text (for example `pack . show` in case of elemets with Show instances) -> IO () indexList sel convert= addTrigger (indext sel convert) where @@ -149,7 +151,7 @@ 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 + refIndex= getDBRef . key $ IndexText t u u u u where u= undefined containsElem :: (IResource a, Typeable a, Typeable b) => (a -> b) -> String -> STM [DBRef a] containsElem sel wstr = do diff --git a/TCache.cabal b/TCache.cabal --- a/TCache.cabal +++ b/TCache.cabal @@ -1,5 +1,5 @@ name: TCache -version: 0.9.0.3 +version: 0.9.0.4 synopsis: A Transactional cache with user-defined persistence description: TCache is a transactional cache with configurable persitence. It allows conventional @@ -7,6 +7,7 @@ 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.4 : solved a bug in the management of weak pointers that "evaporated" registers from the cache 0.9.0.3 : Solved a "lost registers" bug. 0.9.0.1 : Solves a bug when object keys generate invalid filenames. changes in defaultPersistence to further separate serialization from input-output diff --git a/demos/DBRef.hs b/demos/DBRef.hs --- a/demos/DBRef.hs +++ b/demos/DBRef.hs @@ -1,16 +1,16 @@ -{-# OPTIONS -XDeriveDataTypeable #-} +{-# OPTIONS -XDeriveDataTypeable -XFlexibleInstances -XUndecidableInstances #-} module Main where import Data.TCache -import Data.TCache.FilePersistence +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8(pack,unpack) 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 { @@ -19,11 +19,15 @@ ,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 (Read a, Show a) => Serializable a where + serialize= pack . show + deserialize= read . unpack instance Indexable Emp where key Emp{ename= name}= name diff --git a/demos/DynamicSample.hs b/demos/DynamicSample.hs --- a/demos/DynamicSample.hs +++ b/demos/DynamicSample.hs @@ -1,8 +1,9 @@ -{-# OPTIONS -XTypeSynonymInstances #-} +{-# OPTIONS -XTypeSynonymInstances -XFlexibleInstances -XUndecidableInstances #-} -- XTypeSynonymInstances added only to permit IResource instances for Strings module Main where import Data.TCache -import Data.TCache.FilePersistence +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8(pack,unpack) import Data.Typeable {------------- tests--------- @@ -22,13 +23,15 @@ instance Indexable String where key x= take 2 x - +instance (Read a, Show a) => Serializable a where + serialize= pack . show + deserialize= read . unpack main= do putStrLn "see the code to know the meaning of he results" - -- NOTE registerType no longer needed + -- NOTE: registerType no longer needed let x= 1:: Int diff --git a/demos/IndexQuery.hs b/demos/IndexQuery.hs --- a/demos/IndexQuery.hs +++ b/demos/IndexQuery.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-} module Main where import Data.TCache import Data.TCache.IndexQuery -import Data.TCache.FilePersistence +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8(pack,unpack) import Debug.Trace import Data.Typeable @@ -15,6 +16,9 @@ instance Indexable Person where key Person{pname= n} = "Person " ++ n instance Indexable Car where key Car{cname= n} = "Car " ++ n +instance (Read a, Show a) => Serializable a where + serialize= pack . show + deserialize= read . unpack main = do @@ -28,7 +32,7 @@ r <- atomically $ cname .>=. "Bat Mobile" print r - r <- atomically $ select (cname, owner) $ (owner .==. bruce) .&&. (cname .>=. "Bat Mobile") + r <- atomically $ select (cname, owner) $ (owner .==. bruce) .&&. (cname .==. "Bat Mobile") print r diff --git a/demos/basicSample.hs b/demos/basicSample.hs --- a/demos/basicSample.hs +++ b/demos/basicSample.hs @@ -1,17 +1,12 @@ - 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 ------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} +module Main where import Data.TCache - +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8(pack,unpack) import Control.Concurrent +import Data.Typeable import Debug.Trace debug a b= trace b a @@ -21,7 +16,7 @@ data Data= User{uname::String, uid::String, spent:: Int} | Item{iname::String, iid::String, price::Int, stock::Int} - deriving (Read, Show) + deriving (Read, Show, Typeable) -- The mappings between the cache and the phisical storage are defined by the interface IResource @@ -39,8 +34,12 @@ key User{uid=id}= id key Item{iid=id}= id - -- other definable methods: readResource, writeResource delResource. here the default persistence in files are used +instance Serializable Data where + serialize= pack . show + deserialize= read . unpack + + -- buy is the operation to be performed in the example --withResources gets a partial definition of each resource necessary for extracting the key, @@ -52,7 +51,7 @@ user `buy` item= withResources[user,item] buyIt where buyIt[Just us,Just it] - | stock it > 0= [us',it'] `debug` "john buy a PC" + | stock it > 0= [us',it'] `debug` "john buy a PC" | otherwise = error "stock is empty for this product" where @@ -82,7 +81,8 @@ -- 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) + syncCache + threadDelay 1000000 -- the files have been created. the files U12345 and I54321 must contain the result of the 11 iterations diff --git a/demos/caching.hs b/demos/caching.hs --- a/demos/caching.hs +++ b/demos/caching.hs @@ -2,11 +2,12 @@ module Main where ------------------------------------------------- -- TCache example - +-- it ilustrates the use of clearSyncCacheProc while the data is being updated ------------------------------------------------ import Data.TCache -import Data.TCache.FilePersistence +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8(pack,unpack) import Control.Concurrent import Debug.Trace import Data.Typeable @@ -22,8 +23,9 @@ 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 - +instance Serializable Data where + serialize= pack . show + deserialize= read . unpack main= do @@ -40,9 +42,10 @@ 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 $ "every 10 seconds, the modified data in the cache is written in the folder: " ++ defPath ( undefined :: Data) + putStrLn "wait 10 seconds to let the next write cycle to enter (every 10 seconds, set by clearSyncCacheProc)" + 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." diff --git a/demos/triggerRelational.lhs b/demos/triggerRelational.lhs --- a/demos/triggerRelational.lhs +++ b/demos/triggerRelational.lhs @@ -5,15 +5,16 @@ 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 +implements one to many relationships with the use of DBref's and triggers to maintain the relationships. -> {-# LANGUAGE DeriveDataTypeable #-} +> {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances#-} > module Main where > import Data.TCache > import Data.TCache.Triggers -> import Data.TCache.FilePersistence +> import Data.TCache.DefaultPersistence +> import Data.ByteString.Lazy.Char8(pack,unpack) > import Control.Concurrent.STM > import Data.List (delete,nub) > import Data.Typeable @@ -28,6 +29,10 @@ > instance Indexable Person where key Person{pname=n} = "Person " ++ n > instance Indexable Car where key Car{cname= n} = "Car " ++ n +> instance (Read a, Show a) => Serializable a where +> serialize= pack . show +> deserialize= read . unpack + every time a car is added, or deleted the owner's list is updated this is done by the addCar trigger @@ -40,7 +45,7 @@ > deleteOwner powner pcar= do > Just owner <- readDBRef powner -> writeDBRef powner owner{cars= delete pcar $ cars owner} +> writeDBRef powner owner{cars= Data.List.delete pcar $ cars owner} @@ -69,7 +74,7 @@ - - -the car can be used, and the modification of the car register can come from +the car can be sold, 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.