TCache 0.8.0 → 0.8.0.1
raw patch · 4 files changed
+321/−2 lines, 4 files
Files
- Data/TCache/Defs.hs +19/−0
- Data/TCache/IResource.hs +228/−0
- Data/TCache/Triggers.hs +70/−0
- TCache.cabal +4/−2
+ Data/TCache/Defs.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.TCache.Defs where+import Data.Typeable+import Control.Concurrent.STM(TVar)+ ++ +type AccessTime = Integer +type ModifTime = Integer + ++data Status a= NotRead | DoNotExist | Exist a deriving Typeable++data Elem a= Elem a AccessTime ModifTime deriving Typeable+ +type TPVar a= TVar (Status(Elem a))++data DBRef a= DBRef String (TPVar a) deriving Typeable
+ Data/TCache/IResource.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE ScopedTypeVariables+ , UndecidableInstances, FlexibleInstances #-}+module Data.TCache.IResource where ++import Data.Typeable+import System.IO.Unsafe+import Control.Concurrent.STM+import Control.Concurrent+import System.Directory +import Control.Exception as Exception+import System.IO +import System.IO.Error+import Data.List(elemIndices)+import Control.Monad(when,replicateM)+import Data.List(isInfixOf)++--instance (Typeable a, Typeable b) => Typeable (HashTable a b) where+-- typeOf _=mkTyConApp (mkTyCon "Data.HashTable.HashTable") [Data.Typeable.typeOf (undefined ::a), Data.Typeable.typeOf (undefined ::b)]+ +--import Debug.Trace++--debug a b= trace b a + +{- | An IResource instance that must be defined for every object being cached. +there are a set of implicit IResource instance trough utiliy classes (See below)+-}+class IResource a where + {- The `keyResource string must be a unique since this is used to index it in the hash table. + when accessing a resource, the user must provide a partial object for wich the key can be obtained. + for example:+ + @data Person= Person{name, surname:: String, account :: Int ....) + + keyResource Person n s ...= n++s@ + + the data being accesed must define the fields used by keyResource. For example++ @ readResource Person {name="John", surname= "Adams"}@ + + leaving the rest of the fields undefined++ when using default file persistence, the key is used as file name. so it must contain valid filename characters + + -}+ keyResource :: a -> String -- ^ must be defined++ {- | 'readResourceByKey' implements the database access and marshalling or of the object.+ while the database access must be strict, the marshaling must be lazy if, as is often the case,+ some parts of the object are not really accesed.+ Moreover, if the object contains DBRefs, this avoids unnecesary cache lookups+ this method is called inside 'atomically' blocks and thus may be interrupted without calling+ Since STM transactions retry, readResourceByKey may be called twice in strange situations. So it must be idempotent, not only in the result but also in the effect in the database+ -}+ readResourceByKey :: String -> IO(Maybe a)+ -- | the write operation in persistent storage. It must be strict. + -- Since STM transactions may retry, writeResource must be idempotent, not only in the result but also in the effect in the database+ -- all the new obbects are writeen to the database on synchromization+ -- so writeResource must not autocommit.+ -- Commit code must be located in the postcondition. (see 'setConditions')+ writeResource:: a-> IO()++ -- | is called syncronously. It must autocommit + delResource:: a-> IO() ++{- | idempotentProperty k= do+ r <- readResourceByKey k+ r' <- readResourceByKey k+ return (r == r')++++idempotentProperty :: (IResource a) => a -> IO Bool+idempotentProperty x= do+ r <- readResourceByKey $ keyResource x+ r' <- readResourceByKey $ keyResource x+ return (r == r')+ +readResource :: IResource a => a-> IO (Maybe a) +readResource x= readResourceByKey $ keyResource x+-}++ + + +-- | Resources data definition used by 'withSTMResources' +data Resources a b+ = Retry -- ^ forces a retry+ | Resources + { toAdd :: [a] -- ^ resources to be inserted back in the cache+ , toDelete :: [a] -- ^ resources to be deleted from the cache and from permanent storage + , toReturn :: b -- ^ result to be returned + }+ ++-- | Empty resources: @resources= Resources [] [] ()@+resources :: Resources a () +resources = Resources [] [] () + ++++{- | Indexable is an utility class used to derive instances of IResource++Example:++@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)+@++Since Person and Car are instances of 'Read' ans 'Show', by defining the 'Indexable' instance+will implicitly define the IResource instance for file persistence:++@+instance Indexable Person where key Person{pname=n} = \"Person \" ++ n+instance Indexable Car where key Car{cname= n} = \"Car \" ++ n+@+-}+class Indexable a where+ key:: a -> String+ defPath :: a -> String -- ^ additional extension for default file paths.+ -- The default value is "data/".++ -- IMPORTANT: defPath must depend on the datatype, not the value (must be constant). Default is "TCacheData/" + defPath = const "TCacheData/"++--instance IResource a => Indexable a where+-- key x= keyResource x++{- | Serialize is an abstract serialization ionterface in order to define implicit instances of IResource.+The deserialization must be as lazy as possible if deserialized objects contain DBRefs,+lazy deserialization avoid unnecesary DBRef instantiations when they are not accessed,+since DBRefs instantiations involve extra cache lookups+For this reason serialization/deserialization is to/from ordinary Strings+serialization/deserialization are not performance critical in TCache+-}+class Serializable a where+ serialize :: a -> String+ deserialize :: String -> a++{- | Read, Show, instances are implicit instances of Serializable+instance (Show a, Read a) => Serializable a where+ serialize= show+ deserialize= read+-}+++defaultReadResource :: (Serializable a, Indexable a, Typeable a) => a -> IO (Maybe a)+defaultReadResource x= defaultReadResourceByKey $ key x++ +castErr a= r where+ r= case cast a of+ Nothing -> error $ "Type error: " ++ (show $ typeOf a) ++ " does not match "++ (show $ typeOf r)+ ++ "\nThis means that objects of these two types have the same key \nor the retrieved object type is not the stored one for the same key\n"+ Just x -> x+++defaultReadResourceByKey :: (Serializable a, Indexable a) => String-> IO (Maybe a) +defaultReadResourceByKey k= iox+ where+ iox = handle handler $ do + s <- readFileStrict filename :: IO String + return $ Just (deserialize s ) -- `debug` ("read "++ filename) + + filename= defPathIO iox ++ k++ defPathIO ::(Serializable a, Indexable a)=> IO (Maybe a) -> String+ defPathIO iox= defPath x+ where+ Just x= unsafePerformIO $ (return $ Just undefined) `asTypeOf` iox++ + handler :: (Serializable a, Indexable a) => IOError -> IO (Maybe a) + handler e + | isAlreadyInUseError e = defaultReadResourceByKey k + | 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"+ + else defaultReadResourceByKey k+++defaultWriteResource :: (Serializable a, Indexable a) => a-> IO()+defaultWriteResource x= safeWrite filename (serialize x) -- `debug` ("write "++filename) + where+ filename= defPath x ++ key x++safeWrite filename str= handle handler $ writeFile filename str+ where + handler (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" + safeWrite filename str+ +defaultDelResource :: (Indexable a) => a -> IO()+defaultDelResource x= handle (handler filename) $ removeFile filename --`debug` ("delete "++filename) + where+ filename= defPath x ++ key x + handler :: String -> IOError -> IO () + handler file e + | isDoesNotExistError e= return ()+ | isAlreadyInUseError e= do+ --hPutStrLn stderr $ "defaultDelResource: busy" ++ " in file: " ++ filename ++ " retrying"+ threadDelay 1000000+ defaultDelResource x + | otherwise = do+ --hPutStrLn stderr $ "defaultDelResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" + threadDelay 1000000+ defaultDelResource x+ ++ + +-- Strict read from file, needed for default file persistence +readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h+ where+ readIt h= do + s <- hFileSize h + let n= fromIntegral s + str <- replicateM n (hGetChar h) + return str + +
+ Data/TCache/Triggers.hs view
@@ -0,0 +1,70 @@+++{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, BangPatterns #-}+module Data.TCache.Triggers(DBRef(..),Elem(..),Status(..),addTrigger,applyTriggers) where+import Data.TCache.IResource+import Data.TCache.Defs+import Data.Typeable+import Data.IORef+import System.IO.Unsafe+import Unsafe.Coerce+import GHC.Conc (STM, unsafeIOToSTM)+import Data.Maybe(maybeToList,catMaybes)+import Data.List(nubBy)+import Control.Concurrent.STM++import Debug.Trace+import Data.Maybe(fromJust)++newtype TriggerType a= TriggerType (DBRef a -> Maybe a -> STM()) deriving Typeable++data CMTrigger= forall a.(IResource a, Typeable a) => CMTrigger !((DBRef a) -> Maybe a -> STM())++++cmtriggers :: IORef [(TypeRep ,[CMTrigger])]+cmtriggers= unsafePerformIO $ newIORef []++++{- | Add an user defined trigger to the list of triggers+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+-}+addTrigger :: (IResource a, Typeable a) => ((DBRef a) -> Maybe a -> STM()) -> IO()+addTrigger t= do+ map <- readIORef cmtriggers+ writeIORef cmtriggers $+ let ts = mbToList $ lookup atype map+ in nubByType $ (atype ,CMTrigger t : ts) : map+ where+ nubByType= nubBy (\(t,_)(t',_) -> t==t')+ (_,(atype:_))= splitTyConApp . typeOf $ TriggerType t++++mbToList mxs= case mxs of Nothing -> []; Just xs -> xs++applyTriggers:: (IResource a, Typeable a) => [DBRef a] -> [Maybe a] -> STM()+applyTriggers [] _ = return()+applyTriggers dbrfs mas = do+ map <- unsafeIOToSTM $ readIORef cmtriggers+ let ts = mbToList $ lookup (typeOf $ fromJust (head mas)) map+ mapM_ f ts++ where+ f t= mapM2_ (f1 t) dbrfs mas++ f1 ::(IResource a, Typeable a) => CMTrigger -> DBRef a -> Maybe a -> STM()+ f1 (CMTrigger t) dbref ma = (unsafeCoerce t) dbref ma++++mapM2_ _ [] _= return()+mapM2_ f (x:xs) (y:ys)= f x y >> mapM2_ f xs ys++
TCache.cabal view
@@ -1,5 +1,5 @@ name: TCache-version: 0.8.0+version: 0.8.0.1 synopsis: Data caching and Persistent STM transactions description: @@ -47,5 +47,7 @@ build-Depends: base >=4 && <5,directory >= 1.0, old-time >=1.0,stm>=2, containers >= 0.1.0.1, transformers >=0.2 && <0.3 -exposed-modules: Data.TCache, Data.TCache.FilePersistence, Data.TCache.IndexQuery+exposed-modules: Data.TCache, Data.TCache.FilePersistence+ , Data.TCache.IndexQuery, Data.TCache.Triggers+ , Data.TCache.IResource, Data.TCache.Defs ghc-options: -O2