diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,12 @@ +* 0.13.x : (WIP) Major refaktoring and cleanups may break older code +* 0.12.1.0 : Dropped Data.Hashtable (deprecated). Now it uses the package hashtables +* 0.12.0.0 : space in index data in indexQuery.hs and IndexText.hs triggered errors in the AWS backend. The space has been changed by \'-\'. So rename the "index *" files in the TCache folder in order to be recognized. +* 0.11.0.0 : added setIndexParsist to define persistence for indexes by type. started the addition of readDBRefs, readResources and so on for simultaneous read, writes and deletes of objects of the same type. +* 0.10.2.0 : Added setDefaultPersist and modified the signature of setPersist in Data.TCache.DefaultPersistence. Fixed issues with ghc 7.6.3 +* 0.10.0.0 : version add memoization and a persistent and transactional collection/queue. +* 0.10.0.8 : subversion add cachedByKeySTM +* 0.10.0.9 : fixed an error in clearSyncCacheProc and SynWrite Asynchronous that checked the cache continuously +* 0.9.0.4 : Solves a bug in the management of weak pointers that evaporated registers from the cache +* 0.9.0.3 : Solves a lost registers bug. +* 0.9.0.1 : Solves a bug when object keys generate invalid filenames, and includes changes in defaultPersistence to further separate serialization from input-output. +* 0.9.0.0 : Adds full-text indexing and search, which is incorporated into the experimental query language. It also changes the default Persistence mechanism. Now `ByteString`s are used for serialization and deserialization. A `Serializable` class and a `Persist` structure decouples serialization from `ByteString` and read/write to files. Both can be redefined separately, so the default persistence could be changed with `setPersist` to write to blobs in a databases, for example. Default persistence now no longer has to be in files. diff --git a/Data/Persistent/Collection.hs b/Data/Persistent/Collection.hs --- a/Data/Persistent/Collection.hs +++ b/Data/Persistent/Collection.hs @@ -1,250 +1,240 @@ -{-# OPTIONS -XDeriveDataTypeable - -XTypeSynonymInstances - -XMultiParamTypeClasses - -XExistentialQuantification - -XOverloadedStrings - -XFlexibleInstances - -XUndecidableInstances - -XFunctionalDependencies - - #-} - -{- | -A persistent, transactional collection with Queue interface as well as - indexed access by key. - - Uses default persistence. See "Data.TCache.DefaultPersistence" - --} -{- -NOTES -TODO: -data.persistent collection - convertirlo en un tree - añadiendo elementos node Node (refQueue a) - implementar un query language - by key - by attribute (addAttibute) - by class - xpath - implementar un btree sobre el --} -module Data.Persistent.Collection ( -RefQueue(..), getQRef, -pop,popSTM,pick, flush, flushSTM, -pickAll, pickAllSTM, push,pushSTM, -pickElem, pickElemSTM, readAll, readAllSTM, -deleteElem, deleteElemSTM,updateElem,updateElemSTM, -unreadSTM,isEmpty,isEmptySTM -) where -import Data.Typeable -import Control.Concurrent.STM(STM,atomically, retry) -import Control.Monad -import Data.TCache.DefaultPersistence - -import Data.TCache -import System.IO.Unsafe -import Data.RefSerialize -import Data.ByteString.Lazy.Char8 -import Data.RefSerialize - -import Debug.Trace - -a !> b= trace b a - - - - -instance Indexable (Queue a) where - key (Queue k _ _)= queuePrefix ++ k - - - - -data Queue a= Queue {name :: String, imp :: [a], out :: [a]} deriving (Typeable) - - - -instance Serialize a => Serialize (Queue a) where - showp (Queue n i o)= showp n >> showp i >> showp o - readp = return Queue `ap` readp `ap` readp `ap` readp --- do --- n <- readp --- i <- readp --- o <- readp --- return $ Queue n i o - - - - -queuePrefix= "Queue#" -lenQPrefix= Prelude.length queuePrefix - - - -instance Serialize a => Serializable (Queue a ) where - serialize = runW . showp - deserialize = runR readp - --- | A queue reference -type RefQueue a= DBRef (Queue a) - --- | push an element at the top of the queue -unreadSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () -unreadSTM queue x= do - r <- readQRef queue - writeDBRef queue $ doit r - where - doit (Queue n imp out) = Queue n imp ( x : out) - - --- | Check if the queue is empty -isEmpty :: (Typeable a, Serialize a) => RefQueue a -> IO Bool -isEmpty = atomically . isEmptySTM - -isEmptySTM :: (Typeable a, Serialize a) => RefQueue a -> STM Bool -isEmptySTM queue= do - r <- readDBRef queue - return $ case r of - Nothing -> True - Just (Queue _ [] []) -> True - _ -> False - - - --- | Get the reference to new or existing queue trough its name -getQRef :: (Typeable a, Serialize a) => String -> RefQueue a -getQRef n = getDBRef . key $ Queue n undefined undefined - - --- | Empty the queue (factually, it is deleted) -flush :: (Typeable a, Serialize a) => RefQueue a -> IO () -flush = atomically . flushSTM - --- | Version in the STM monad -flushSTM :: (Typeable a, Serialize a) => RefQueue a -> STM () -flushSTM tv= delDBRef tv - --- | Read the first element in the queue and delete it (pop) -pop - :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name - -> IO a -- ^ the returned elems -pop tv = atomically $ popSTM tv - - -readQRef :: (Typeable a, Serialize a) => RefQueue a -> STM(Queue a) -readQRef tv= do - mdx <- readDBRef tv - case mdx of - Nothing -> do - let q= Queue ( Prelude.drop lenQPrefix $ keyObjDBRef tv) [] [] - writeDBRef tv q - return q - Just dx -> - return dx - --- | Version in the STM monad -popSTM :: (Typeable a, Serialize a) => RefQueue a - -> STM a -popSTM tv=do - dx <- readQRef tv - doit dx - - where - - doit (Queue n [x] [])= do - writeDBRef tv $ (Queue n [] []) - return x - doit (Queue _ [] []) = retry - doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) - doit (Queue n imp list ) = do - writeDBRef tv (Queue n imp (Prelude.tail list )) - return $ Prelude.head list - --- | Read the first element in the queue but it does not delete it -pick - :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name - -> IO a -- ^ the returned elems -pick tv = atomically $ do - dx <- readQRef tv - doit dx - where - doit (Queue _ [x] [])= return x - doit (Queue _ [] []) = retry - doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) - doit (Queue n imp list ) = return $ Prelude.head list - --- | Push an element in the queue -push :: (Typeable a, Serialize a) => RefQueue a -> a -> IO () -push tv v = atomically $ pushSTM tv v - --- | Version in the STM monad -pushSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () -pushSTM tv v= - readQRef tv >>= \ ((Queue n imp out)) -> writeDBRef tv $ Queue n (v : imp) out - --- | Return the list of all elements in the queue. The queue remains unchanged -pickAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] -pickAll= atomically . pickAllSTM - --- | Version in the STM monad -pickAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] -pickAllSTM tv= do - (Queue name imp out) <- readQRef tv - return $ out ++ Prelude.reverse imp - --- | Return the first element in the queue that has the given key -pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a) -pickElem tv key= atomically $ pickElemSTM tv key - --- | Version in the STM monad -pickElemSTM :: (Indexable a,Typeable a, Serialize a) - => RefQueue a -> String -> STM(Maybe a) -pickElemSTM tv key1= do - Queue name imp out <- readQRef tv - let xs= out ++ Prelude.reverse imp - when (not $ Prelude.null imp) $ writeDBRef tv $ Queue name [] xs - case Prelude.filter (\x-> key x == key1) xs of - [] -> return $ Nothing - (x:_) -> return $ Just x - --- | Update the first element of the queue with a new element with the same key -updateElem :: (Indexable a,Typeable a, Serialize a) - => RefQueue a -> a -> IO() -updateElem tv x = atomically $ updateElemSTM tv x - --- | Version in the STM monad -updateElemSTM :: (Indexable a,Typeable a, Serialize a) - => RefQueue a -> a -> STM() -updateElemSTM tv v= do - Queue name imp out <- readQRef tv - let xs= out ++ Prelude.reverse imp - let xs'= Prelude.map (\x -> if key x == n then v else x) xs - writeDBRef tv $ Queue name [] xs' - where - n= key v - --- | Return the list of all elements in the queue and empty it -readAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] -readAll= atomically . readAllSTM - --- | A version in the STM monad -readAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] -readAllSTM tv= do - Queue name imp out <- readQRef tv - writeDBRef tv $ Queue name [] [] - return $ out ++ Prelude.reverse imp - --- | Delete all the elements of the queue that has the key of the parameter passed -deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO () -deleteElem tv x= atomically $ deleteElemSTM tv x - --- | Verison in the STM monad -deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM () -deleteElemSTM tv x= do - Queue name imp out <- readQRef tv - let xs= out ++ Prelude.reverse imp - writeDBRef tv $ Queue name [] $ Prelude.filter (\x-> key x /= k) xs - where - k=key x - +{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, + MultiParamTypeClasses, ExistentialQuantification, + OverloadedStrings, FlexibleInstances, UndecidableInstances #-} + +{- | +A persistent, transactional collection with Queue interface as well as + indexed access by key. + + Uses default persistence. See "Data.TCache.DefaultPersistence" + +-} +{- +NOTES +TODO: +data.persistent collection + convertirlo en un tree + añadiendo elementos node Node (refQueue a) + implementar un query language + by key + by attribute (addAttibute) + by class + xpath + implementar un btree sobre el +-} +module Data.Persistent.Collection ( +RefQueue, getQRef, +pop,popSTM,pick, flush, flushSTM, +pickAll, pickAllSTM, push,pushSTM, +pickElem, pickElemSTM, readAll, readAllSTM, +deleteElem, deleteElemSTM,updateElem,updateElemSTM, +unreadSTM,isEmpty,isEmptySTM +) where +import Data.Typeable +import Control.Concurrent.STM(STM,atomically, retry) +import Control.Monad +import Data.TCache.DefaultPersistence + +import Data.TCache +import Data.RefSerialize + +--import Debug.Trace +--(!>) :: a -> String -> a +--a !> b= trace b a + + + + +instance Indexable (Queue a) where + key (Queue k _ _)= queuePrefix ++ k + + + + +data Queue a= Queue String [a] [a] deriving (Typeable) + + + +instance Serialize a => Serialize (Queue a) where + showp (Queue n i o)= showp n >> showp i >> showp o + readp = return Queue `ap` readp `ap` readp `ap` readp +-- do +-- n <- readp +-- i <- readp +-- o <- readp +-- return $ Queue n i o + + + +queuePrefix :: String +queuePrefix= "Queue#" + +lenQPrefix :: Int +lenQPrefix= Prelude.length queuePrefix + +instance Serialize a => Serializable (Queue a ) where + serialize = runW . showp + deserialize = runR readp + +-- | A queue reference +type RefQueue a= DBRef (Queue a) + +-- | push an element at the top of the queue +unreadSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () +unreadSTM queue x= do + r <- readQRef queue + writeDBRef queue $ doit r + where + doit (Queue n imp out) = Queue n imp ( x : out) + + +-- | Check if the queue is empty +isEmpty :: (Typeable a, Serialize a) => RefQueue a -> IO Bool +isEmpty = atomically . isEmptySTM + +isEmptySTM :: (Typeable a, Serialize a) => RefQueue a -> STM Bool +isEmptySTM queue= do + r <- readDBRef queue + return $ case r of + Nothing -> True + Just (Queue _ [] []) -> True + _ -> False + + + +-- | Get the reference to new or existing queue trough its name +getQRef :: (Typeable a, Serialize a) => String -> RefQueue a +getQRef n = getDBRef . key $ Queue n undefined undefined + + +-- | Empty the queue (factually, it is deleted) +flush :: (Typeable a, Serialize a) => RefQueue a -> IO () +flush = atomically . flushSTM + +-- | Version in the STM monad +flushSTM :: (Typeable a, Serialize a) => RefQueue a -> STM () +flushSTM = delDBRef + +-- | Read the first element in the queue and delete it (pop) +pop + :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name + -> IO a -- ^ the returned elems +pop tv = atomically $ popSTM tv + + +readQRef :: (Typeable a, Serialize a) => RefQueue a -> STM(Queue a) +readQRef tv= do + mdx <- readDBRef tv + case mdx of + Nothing -> do + let q= Queue ( Prelude.drop lenQPrefix $ keyObjDBRef tv) [] [] + writeDBRef tv q + return q + Just dx -> + return dx + +-- | Version in the STM monad +popSTM :: (Typeable a, Serialize a) => RefQueue a + -> STM a +popSTM tv=do + dx <- readQRef tv + doit dx + + where + + doit (Queue n [x] [])= do + writeDBRef tv (Queue n [] []) + return x + doit (Queue _ [] []) = retry + doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) + doit (Queue n imp list ) = do + writeDBRef tv (Queue n imp (Prelude.tail list )) + return $ Prelude.head list + +-- | Read the first element in the queue but it does not delete it +pick + :: (Typeable a, Serialize a) => RefQueue a -- ^ Queue name + -> IO a -- ^ the returned elems +pick tv = atomically $ do + dx <- readQRef tv + doit dx + where + doit (Queue _ [x] [])= return x + doit (Queue _ [] []) = retry + doit (Queue n imp []) = doit (Queue n [] $ Prelude.reverse imp) + doit (Queue _ _ list ) = return $ Prelude.head list + +-- | Push an element in the queue +push :: (Typeable a, Serialize a) => RefQueue a -> a -> IO () +push tv v = atomically $ pushSTM tv v + +-- | Version in the STM monad +pushSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () +pushSTM tv v= + readQRef tv >>= \ (Queue n imp out) -> writeDBRef tv $ Queue n (v : imp) out + +-- | Return the list of all elements in the queue. The queue remains unchanged +pickAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] +pickAll= atomically . pickAllSTM + +-- | Version in the STM monad +pickAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] +pickAllSTM tv= do + (Queue _ imp out) <- readQRef tv + return $ out ++ Prelude.reverse imp + +-- | Return the first element in the queue that has the given key +pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a) +pickElem tv k= atomically $ pickElemSTM tv k + +-- | Version in the STM monad +pickElemSTM :: (Indexable a,Typeable a, Serialize a) + => RefQueue a -> String -> STM(Maybe a) +pickElemSTM tv key1 = do + Queue name imp out <- readQRef tv + let xs = out ++ Prelude.reverse imp + unless (Prelude.null imp) $ writeDBRef tv $ Queue name [] xs + case Prelude.filter (\x -> key x == key1) xs of + [] -> return Nothing + (x:_) -> return $ Just x + +-- | Update the first element of the queue with a new element with the same key +updateElem :: (Indexable a,Typeable a, Serialize a) + => RefQueue a -> a -> IO() +updateElem tv x = atomically $ updateElemSTM tv x + +-- | Version in the STM monad +updateElemSTM :: (Indexable a,Typeable a, Serialize a) + => RefQueue a -> a -> STM() +updateElemSTM tv v= do + Queue name imp out <- readQRef tv + let xs= out ++ Prelude.reverse imp + let xs'= Prelude.map (\x -> if key x == n then v else x) xs + writeDBRef tv $ Queue name [] xs' + where + n= key v + +-- | Return the list of all elements in the queue and empty it +readAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a] +readAll= atomically . readAllSTM + +-- | A version in the STM monad +readAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a] +readAllSTM tv= do + Queue name imp out <- readQRef tv + writeDBRef tv $ Queue name [] [] + return $ out ++ Prelude.reverse imp + +-- | Delete all the elements of the queue that has the key of the parameter passed +deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO () +deleteElem tv x= atomically $ deleteElemSTM tv x + +-- | Version in the STM monad +deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM () +deleteElemSTM tv x= do + Queue name imp out <- readQRef tv + let xs= out ++ Prelude.reverse imp + writeDBRef tv $ Queue name [] $ Prelude.filter (\x2-> key x2 /= k) xs + where + k=key x + diff --git a/Data/Persistent/IDynamic.hs b/Data/Persistent/IDynamic.hs --- a/Data/Persistent/IDynamic.hs +++ b/Data/Persistent/IDynamic.hs @@ -1,157 +1,150 @@ - {-# OPTIONS -XExistentialQuantification - -XOverlappingInstances - -XUndecidableInstances - -XScopedTypeVariables - -XDeriveDataTypeable - -XTypeSynonymInstances - -XIncoherentInstances - -XOverloadedStrings - -XMultiParamTypeClasses - -XFunctionalDependencies - -XFlexibleInstances #-} -{- | -IDynamic is a indexable and serializable version of Dynamic. (See @Data.Dynamic@). It is used as containers of objects -in the cache so any new datatype can be incrementally stored without recompilation. -IDimamic provices methods for safe casting, besides serializaton, deserialirezation and retrieval by key. --} -module Data.Persistent.IDynamic where -import Data.Typeable -import Unsafe.Coerce -import System.IO.Unsafe -import Data.TCache -import Data.TCache.Defs - -import Data.Char (showLitChar) - -import Data.ByteString.Lazy.Char8 as B - -import Data.Word -import Numeric (showHex, readHex) -import Control.Exception(handle, SomeException, ErrorCall) -import Control.Monad(replicateM) -import Data.Word -import Control.Concurrent.MVar -import Data.IORef -import Data.Map as M(empty) -import Data.RefSerialize - ---import Debug.Trace ---(!>)= flip trace - - -data IDynamic = IDyn (IORef IDynType) deriving Typeable - -data IDynType= forall a w r.(Typeable a, Serialize a) - => DRight !a - | DLeft !(ByteString ,(Context, ByteString)) - - - deriving Typeable - -newtype Save= Save ByteString deriving Typeable - -tosave d@(IDyn r)= unsafePerformIO $ do - mr<- readIORef r - case mr of - DRight _ -> return d - DLeft (s,_) -> writeIORef r (DRight $ Save s) >> return d - - -instance Serialize Save where - showp (Save s)= insertString s - readp = error "readp not impremented for Save" - - -errorfied str str2= error $ str ++ ": IDynamic object not reified: "++ str2 - - - -dynPrefix= "Dyn" -dynPrefixSp= append (pack dynPrefix) " " -notreified = pack $ dynPrefix ++" 0" - - - -instance Serialize IDynamic where - - showp (IDyn t)= - case unsafePerformIO $ readIORef t of - DRight x -> do --- insertString $ pack dynPrefix - c <- getWContext - showpx <- rshowps x --- showpText . fromIntegral $ B.length showpx - showp $ unpack showpx - - DLeft (showpx,_) -> -- error $ "IDynamic not reified :: "++ unpack showpx --- insertString notreified - insertString $ encode showpx - where - encode = pack . show . unpack - - readp = lexeme (do --- symbol dynPrefix --- n <- readpText --- s <- takep n - - s <- rreadp :: STR String - - c <- getRContext - return . IDyn . unsafePerformIO . newIORef $ DLeft ( pack s, c)) - "IDynamic" - - - -instance Show IDynamic where - show (IDyn r) = - let t= unsafePerformIO $ readIORef r - in case t of - DRight x -> "IDyn " ++ ( unpack . runW $ showp x) - DLeft (s, _) -> "IDyns \"" ++ unpack s ++ "\"" - - - - - -toIDyn x= IDyn . unsafePerformIO . newIORef $ DRight x - --- | check if a (possibly polimorphic) value within a IDynamic value has the given serialization" -serializedEqual (IDyn r) str= unsafePerformIO $ do - t <- readIORef r - case t of - DRight x -> return $ runW (showp x) == str -- !> ("R "++ (show $ unpack $ runW (showp x))) - DLeft (str', _) -> return $ str== str' -- !> ("L "++ (show $ unpack str' )) - -fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a -fromIDyn x= case safeFromIDyn x of - Left s -> error s - Right v -> v - - -safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a -safeFromIDyn (d@(IDyn r))= final where - final= unsafePerformIO $ do - t <- readIORef r - case t of - DRight x -> return $ case cast x of - Nothing -> Left $ "fromIDyn: unable to extract from " - ++ show d ++ " something of type: " - ++ (show . typeOf $ fromRight final) - Just x -> Right x - where - fromRight (Right x)= x - - - DLeft (str, c) -> - handle (\(e :: SomeException) -> return $ Left (show e)) $ -- !> ("safeFromIDyn : "++ show e)) $ - do - let v= runRC c rreadp str -- !> unpack str - writeIORef r $! DRight v -- !> ("***reified "++ unpack str) - return $! Right v -- !> ("*** end reified " ++ unpack str) - - - -reifyM :: (Typeable a,Serialize a) => IDynamic -> a -> IO a -reifyM dyn v = do - let v'= fromIDyn dyn - return $ v' `seq` v' +{-# LANGUAGE ExistentialQuantification, UndecidableInstances, + ScopedTypeVariables, DeriveDataTypeable, TypeSynonymInstances, + IncoherentInstances, OverloadedStrings, MultiParamTypeClasses, + FlexibleInstances #-} + +{- | +IDynamic is a indexable and serializable version of Dynamic. (See @Data.Dynamic@). It is used as containers of objects +in the cache so any new datatype can be incrementally stored without recompilation. +IDimamic provices methods for safe casting, besides serializaton, deserialirezation and retrieval by key. +-} +module Data.Persistent.IDynamic where +import Data.Typeable +import System.IO.Unsafe + +import Data.ByteString.Lazy.Char8 as B + +import Control.Exception(handle, SomeException) +import Data.IORef +import Data.RefSerialize + +--import Debug.Trace +--(!>)= flip trace + + +newtype IDynamic = IDyn (IORef IDynType) deriving Typeable + +data IDynType= forall a.(Typeable a, Serialize a) + => DRight !a + | DLeft !(ByteString ,(Context, ByteString)) + + + deriving Typeable + +newtype Save= Save ByteString deriving Typeable + +tosave :: IDynamic -> IDynamic +tosave d@(IDyn r)= unsafePerformIO $ do + mr<- readIORef r + case mr of + DRight _ -> return d + DLeft (s,_) -> writeIORef r (DRight $ Save s) >> return d + + +instance Serialize Save where + showp (Save s)= insertString s + readp = error "readp not impremented for Save" + + +errorfied :: String -> String -> a +errorfied str str2= error $ str ++ ": IDynamic object not reified: "++ str2 + + + +dynPrefix :: String +dynPrefix= "Dyn" + +dynPrefixSp :: ByteString +dynPrefixSp= append (pack dynPrefix) " " + +notreified :: ByteString +notreified = pack $ dynPrefix ++" 0" + + + +instance Serialize IDynamic where + + showp (IDyn t)= + case unsafePerformIO $ readIORef t of + DRight x -> do +-- insertString $ pack dynPrefix + _ <- getWContext + showpx <- rshowps x +-- showpText . fromIntegral $ B.length showpx + showp $ unpack showpx + + DLeft (showpx,_) -> -- error $ "IDynamic not reified :: "++ unpack showpx +-- insertString notreified + insertString $ encode showpx + where + encode = pack . show . unpack + + readp = lexeme (do +-- symbol dynPrefix +-- n <- readpText +-- s <- takep n + + s <- rreadp :: STR String + + c <- getRContext + return . IDyn . unsafePerformIO . newIORef $ DLeft ( pack s, c)) + "IDynamic" + + + +instance Show IDynamic where + show (IDyn r) = + let t= unsafePerformIO $ readIORef r + in case t of + DRight x -> "IDyn " ++ ( unpack . runW $ showp x) + DLeft (s, _) -> "IDyns \"" ++ unpack s ++ "\"" + + + + + +toIDyn :: (Typeable a, Serialize a) => a -> IDynamic +toIDyn x= IDyn . unsafePerformIO . newIORef $ DRight x + +-- | check if a (possibly polimorphic) value within a IDynamic value has the given serialization" +serializedEqual :: IDynamic -> ByteString -> Bool +serializedEqual (IDyn r) str= unsafePerformIO $ do + t <- readIORef r + case t of + DRight x -> return $ runW (showp x) == str -- !> ("R "++ (show $ unpack $ runW (showp x))) + DLeft (str', _) -> return $ str== str' -- !> ("L "++ (show $ unpack str' )) + +fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a +fromIDyn x= case safeFromIDyn x of + Left s -> error s + Right v -> v + + +safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a +safeFromIDyn d@(IDyn r) = final + where + final = + unsafePerformIO $ do + t <- readIORef r + case t of + DRight x -> + return $ + case cast x of + Nothing -> + Left $ + "fromIDyn: unable to extract from " ++ + show d ++ " something of type: " ++ (show . typeOf $ fromRight final) + Just x' -> Right x' + where fromRight (Right x') = x' + fromRight (Left _') = error "this will never happen?" + DLeft (str, c) -> + handle (\(e :: SomeException) -> return $ Left (show e)) $ -- !> ("safeFromIDyn : "++ show e)) $ + do + let v = runRC c rreadp str -- !> unpack str + writeIORef r $! DRight v -- !> ("***reified "++ unpack str) + return (Right v) -- !> ("*** end reified " ++ unpack str) + + + +reifyM :: (Typeable a,Serialize a) => IDynamic -> a -> IO a +reifyM dyn _ = return $ fromIDyn dyn diff --git a/Data/TCache.hs b/Data/TCache.hs --- a/Data/TCache.hs +++ b/Data/TCache.hs @@ -1,1040 +1,1061 @@ -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable - , FlexibleInstances, UndecidableInstances #-} - -{- | TCache is a transactional cache with configurable persitence that permits -STM transactions with objects that syncronize sincromous or asyncronously with -their user defined storages. Default persistence in files is provided by default - - TCache implements ''DBRef' 's . They are persistent STM references with a typical Haskell interface. -simitar to TVars ('newDBRef', 'readDBRef', 'writeDBRef' etc) but with added. persistence -. DBRefs are serializable, so they can be stored and retrieved. -Because they are references,they point to other serializable registers. -This permits persistent mutable Inter-object relations - -For simple transactions of lists of objects of the same type TCache implements -inversion of control primitives 'withSTMResources' and variants, that call pure user defined code for registers update. Examples below. - -Triggers in "Data.TCache.Triggers" are user defined hooks that are called back on register updates. -.They are used internally for indexing. - -"Data.TCache.IndexQuery" implements an straighforwards pure haskell type safe query language based - on register field relations. This module must be imported separately. - -"Data.TCache.IndexText" add full text search and content search to the query language - -"Data.TCache.DefaultPersistence" has instances for key indexation , serialization - and default file persistence. The file persistence is more reliable, and the embedded IO reads inside STM transactions are safe. - -"Data.Persistent.Collection" implements a persistent, transactional collection with Queue interface as well as - indexed access by key - --} - - - - -module Data.TCache ( --- * Inherited from 'Control.Concurrent.STM' and variations - - atomically - ,atomicallySync - ,STM - ,unsafeIOToSTM - ,safeIOToSTM - --- * Operations with cached database references -{-| @DBRefs@ are persistent cached database references in the STM monad -with read/write primitives, so the traditional syntax of Haskell STM references -can be used for interfacing with databases. As expected, the DBRefs are transactional, - because they operate in the STM monad. - -A @DBRef@ is associated with its referred object trough its key. -Since DBRefs are serializable, they can be elements of mutable cached objects themselves. They could point to other mutable objects -and so on, so DBRefs can act as \"hardwired\" relations from mutable objects -to other mutable objects in the database/cache. their referred objects are loaded, saved and flused -to and from the cache automatically depending on the cache handling policies and the access needs - - -@DBRefs@ are univocally identified by its pointed object keys, so they can be compared, ordered checked for equality so on. -The creation of a DBRef, trough 'getDBRef' is pure. This permits an efficient lazy access to the - registers trouth their DBRefs by lazy marshalling of the register content on demand. - -Example: Car registers have references to Person regiters - -@ -data Person= Person {pname :: String} deriving (Show, Read, Eq, Typeable) -data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable) -@ - - -Here the Car register point to the Person register trough the owner field - -To permit persistence and being refered with DBRefs, define the Indexable instance -for these two register types: - -@ -instance Indexable Person where key Person{pname= n} = "Person " ++ n -instance Indexable Car where key Car{cname= n} = "Car " ++ n -@ - -Now we create a DBRef to a Person whose name is \"Bruce\" - ->>> let bruce = getDBRef . key $ Person "Bruce" :: DBRef Person - ->>> show bruce ->"DBRef \"Person bruce\"" - ->>> atomically (readDBRef bruce) ->Nothing - -'getDBRef' is pure and creates the reference, but not the referred object; -To create both the reference and the DBRef, use 'newDBRef'. -Lets create two Car's and its two Car DBRefs with bruce as owner: - ->>> cars <- atomically $ mapM newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"] - ->>> print cars ->[DBRef "Car Bat Mobile",DBRef "Car Porsche"] - ->>> carRegs<- atomically $ mapM readDBRef cars -> [Just (Car {owner = DBRef "Person bruce", cname = "Bat Mobile"}) -> ,Just (Car {owner = DBRef "Person bruce", cname = "Porsche"})] - -try to write with 'writeDBRef' - ->>> atomically . writeDBRef bruce $ Person "Other" ->*** Exception: writeDBRef: law of key conservation broken: old , new= Person bruce , Person Other - -DBRef's can not be written with objects of different keys - ->>> atomically . writeDBRef bruce $ Person "Bruce" - ->>> let Just carReg1= head carRegs - -now from the Car register it is possible to recover the owner's register - ->>> atomically $ readDBRef ( owner carReg1) ->Just (Person {pname = "bruce"}) - - - -DBRefs, once the pointed cached object is looked up in the cache and found at creation, they does -not perform any further cache lookup afterwards, so reads and writes from/to DBRefs are faster -than *Resource(s) calls, which perform cache lookups everytime the object is accessed - -DBRef's and @*Resource(s)@ primitives are completely interoperable. The latter operate implicitly with DBRef's - --} - - -,DBRef -,getDBRef -,keyObjDBRef -,newDBRef ---,newDBRefIO -,readDBRef -,readDBRefs -,writeDBRef -,delDBRef - --- * @IResource@ class -{- | cached objects must be instances of IResource. -Such instances can be implicitly derived trough auxiliary clasess for file persistence --} -,IResource(..) - --- * Operations with cached objects -{- | implement inversion of control primitives where the user defines the objects to retrive. The primitives -then call a the defined function that, determines how to transform the objects retrieved,wich are sent -back to the storage and a result is returned. - -In this example \"buy\" is a transaction where the user buy an item. -The spent amount is increased and the stock of the product is decreased: - -@ -data Data= User{uname:: String, uid:: String, spent:: Int} | - Item{iname:: String, iid:: String, price:: Int, stock:: Int} - deriving (Read, Show) - -instance Indexable Data where - key User{uid=id}= id - key Item{iid=id}= id - -user `buy` item= 'withResources'[user,item] buyIt - where - buyIt[Just us,Just it] - | stock it > 0= [us',it'] - | otherwise = error \"stock is empty for this product\" - where - us'= us{spent=spent us + price it} - it'= it{stock= stock it-1} - buyIt _ = error \"either the user or the item (or both) does not exist\" -@ --} -,Resources(..) -- data definition used to communicate object Inserts and Deletes to the cache -,resources -- empty resources -,withSTMResources -,withResources -,withResource -,getResources -,getResource -,deleteResources -,deleteResource - --- * Trigger operations -{- | Trriggers are called just before an object of the given type is created, modified or deleted. -The DBRef to the object and the new value is passed to the trigger. -The called trigger function has two parameters: the DBRef being accesed -(which still contains the old value), and the new value. -If the content of the DBRef is being deleted, the second parameter is 'Nothing'. -if the DBRef contains Nothing, then the object is being created - -Example: - -Every time a car is added, or deleted, the owner's list is updated. -This is done by the user defined trigger addCar - -@ - addCar pcar (Just(Car powner _ )) = addToOwner powner pcar - addCar pcar Nothing = readDBRef pcar >>= \\(Just car)-> deleteOwner (owner car) pcar - - addToOwner powner pcar=do - Just owner <- readDBRef powner - writeDBRef powner owner{cars= nub $ pcar : cars owner} - - deleteOwner powner pcar= do - Just owner <- readDBRef powner - writeDBRef powner owner{cars= delete pcar $ cars owner} - - main= do - 'addTrigger' addCar - putStrLn \"create bruce's register with no cars\" - bruce \<- 'atomically' 'newDBRef' $ Person \"Bruce\" [] - putStrLn \"add two car register with \\"bruce\\" as owner using the reference to the bruces register\" - let newcars= [Car bruce \"Bat Mobile\" , Car bruce \"Porsche\"] - insert newcars - Just bruceData \<- atomically $ 'readDBRef' bruce - putStrLn \"the trigger automatically updated the car references of the Bruce register\" - print . length $ cars bruceData - print bruceData -@ - -gives: - -> main -> 2 -> Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]} - --} - -,addTrigger - --- * Cache control -{-- | - -The mechanism for dropping elements from the cache is too lazy. `flushDBRef`, for example -just delete the data element from the TVar, but the TVar node -remains attached to the table so there is no decrement on the number of elements. -The element is garbage collected unless you have a direct reference to the element, not the DBRef -Note that you can still have a valid reference to this element, but this element is no longer -in the cache. The usual thing is that you do not have it, and the element will be garbage -collected (but still there will be a NotRead entry for this key!!!). If the DBRef is read again, the -TCache will go to permanent storage to retrieve it. - -clear opertions such `clearsyncCache` does something similar: it does not delete the -element from the cache. It just inform the garbage collector that there is no longer necessary to maintain -the element in the cache. So if the element has no other references (maybe you keep a -variable that point to that DBRef) it will be GCollected. -If this is not possible, it will remain in the cache and will be treated as such, -until the DBRef is no longer referenced by the program. This is done by means of a weak pointer - -All these complications are necessary because the programmer can handle DBRefs directly, -so the cache has no complete control of the DBRef life cycle, short to speak. - -a DBRef can be in the states: - -- `Exist`: it is in the cache - -- `DoesNotExist`: neither is in the cache neither in storage: it is like a cached "notfound" to -speed up repeated failed requests - -- `NotRead`: may exist or not in permanent storage, but not in the cache - - -In terms of Garbage collection it may be: - - - -1 - pending garbage collection: attached to the hashtable by means of a weak pointer: delete it asap - -2 - cached: attached by a direct pointer and a weak pointer: It is being cached - - -clearsyncCache just pass elements from 2 to 1 - ---} -,flushDBRef -,flushKey -,invalidateKey -,flushAll -,Cache -,setCache -,newCache ---,refcache -,syncCache -,setConditions -,clearSyncCache -,numElems -,syncWrite -,SyncMode(..) -,clearSyncCacheProc -,defaultCheck --- * Other -,onNothing -) -where - - -import GHC.Conc -import Control.Monad(when) -import qualified Data.HashTable.IO as H -import Data.IORef -import System.IO.Unsafe -import System.IO(hPutStr, stderr) -import Data.Maybe -import Data.Char(isSpace) -import Data.TCache.Defs -import Data.TCache.IResource -import Data.TCache.Triggers -import Control.Exception -import Data.Typeable -import System.Time -import System.Mem -import System.Mem.Weak - -import Control.Concurrent.MVar -import Control.Exception(catch, throw,evaluate) - ---import Debug.Trace ---(!>) = flip trace - --- there are two references to the DBRef here --- The Maybe one keeps it alive until the cache releases it for *Resources --- calls which does not reference dbrefs explicitly --- The weak reference keeps the dbref alive until is it not referenced elsewere -data CacheElem= forall a.(IResource a,Typeable a) => CacheElem (Maybe (DBRef a)) (Weak(DBRef a)) - -type Ht = H.BasicHashTable String CacheElem - --- contains the hastable, last sync time -type Cache = IORef (Ht , Integer) -data CheckTPVarFlags= AddToHash | NoAddToHash - --- | Set the cache. this is useful for hot loaded modules that will update an existing cache. Experimental -setCache :: Cache -> IO() -setCache ref = readIORef ref >>= \ch -> writeIORef refcache ch - --- | The cache holder. stablished by default -{-# NOINLINE refcache #-} -refcache :: Cache -refcache =unsafePerformIO $ newCache >>= newIORef - --- | Creates a new cache. Experimental -newCache :: IO (Ht , Integer) -newCache =do - c <- H.new -- (==) H.hashString - return (c,0) - --- | Return the total number of DBRefs in the cache. For debug purposes. --- This does not count the number of objects in the cache since many of the DBRef --- may not have the pointed object loaded. It's O(n). -numElems :: IO Int -numElems= do - (cache, _) <- readIORef refcache - elems <- H.toList cache - return $ length elems - -{-# NOINLINE deRefWeakSTM #-} -deRefWeakSTM = unsafeIOToSTM . deRefWeak - ---deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO () ---deleteFromCache (DBRef k tv)= do --- (cache, _) <- readIORef refcache --- H.delete cache k -- !> ("delete " ++ k) - -fixToCache :: (IResource a, Typeable a) => DBRef a -> IO () -fixToCache dbref@(DBRef k tv)= do - (cache, _) <- readIORef refcache - w <- mkWeakPtr dbref $ Just $ fixToCache dbref - H.insert cache k (CacheElem (Just dbref) w) - return() - --- | Return the reference value. If it is not in the cache, it is fetched --- from the database. -readDBRef :: (IResource a, Typeable a) => DBRef a -> STM (Maybe a) -readDBRef dbref@(DBRef key tv)= do - r <- readTVar tv - case r of - Exist (Elem x _ mt) -> do - t <- unsafeIOToSTM timeInteger - writeTVar tv . Exist $ Elem x t mt - return $ Just x - DoNotExist -> return $ Nothing - NotRead -> do - r <- safeIOToSTM $ readResourceByKey key - case r of - Nothing -> writeTVar tv DoNotExist >> return Nothing - Just x -> do - t <- unsafeIOToSTM timeInteger - writeTVar tv $ Exist $ Elem x t (-1) - return $ Just x - --- | Read multiple DBRefs in a single request using the new 'readResourcesByKey' -readDBRefs :: (IResource a, Typeable a) => [DBRef a] -> STM [(Maybe a)] -readDBRefs dbrefs= do - let mf (DBRef key tv)= do - r <- readTVar tv - case r of - Exist (Elem x _ mt) -> do - t <- unsafeIOToSTM timeInteger - writeTVar tv . Exist $ Elem x t mt - return $ Right $ Just x - DoNotExist -> return $ Right Nothing - NotRead -> return $ Left key - inCache <- mapM mf dbrefs - let pairs = foldr(\pair@(x,dbr) xs -> case x of Left k -> pair:xs; _ -> xs ) [] $ zip inCache dbrefs - let (toReadKeys, dbrs) = unzip pairs - let fromLeft (Left k)= k - formLeft _ = error "this will never happen" - rs <- safeIOToSTM . readResourcesByKey $ map fromLeft toReadKeys - let processTVar (r, DBRef key tv)= do - case r of - Nothing -> writeTVar tv DoNotExist - Just x -> do - t <- unsafeIOToSTM timeInteger - writeTVar tv $ Exist $ Elem x t (-1) - - mapM_ processTVar $ zip rs dbrs - let mix (Right x:xs) ys = x:mix xs ys - mix (Left _:xs) (y:ys)= y:mix xs ys - - return $ mix inCache rs - --- | Write in the reference a value --- The new key must be the same than the old key of the previous object stored --- otherwise, an error "law of key conservation broken" will be raised --- --- WARNING: the value to be written in the DBRef must be fully evaluated. Delayed evaluations at --- serialization time can cause inconsistencies in the database. --- In future releases this will be enforced. -writeDBRef :: (IResource a, Typeable a) => DBRef a -> a -> STM () -writeDBRef dbref@(DBRef key tv) x= x `seq` do - let newkey= keyResource x - if newkey /= key - then error $ "writeDBRef: law of key conservation broken: old , new= " ++ key ++ " , "++newkey - else do - applyTriggers [dbref] [Just x] - t <- unsafeIOToSTM timeInteger - - writeTVar tv $! Exist $! Elem x t t - return() - - -instance Show (DBRef a) where - show (DBRef key _)= "DBRef \""++ key ++ "\"" - -instance (IResource a, Typeable a) => Read (DBRef a) where - readsPrec n str1= readit str - where - str = dropWhile isSpace str1 - readit ('D':'B':'R':'e':'f':' ':'\"':str1)= - let (key,nstr) = break (== '\"') str1 - in [( getDBRef key :: DBRef a, tail nstr)] - readit _ = [] - -instance Eq (DBRef a) where - DBRef k _ == DBRef k' _ = k==k' - -instance Ord (DBRef a) where - compare (DBRef k _) (DBRef k' _) = compare k k' - --- | Return the key of the object pointed to by the DBRef -keyObjDBRef :: DBRef a -> String -keyObjDBRef (DBRef k _)= k - - --- | Get the reference to the object in the cache. if it does not exist, the reference is created empty. --- Every execution of 'getDBRef' returns the same unique reference to this key, --- so it can be safely considered pure. This is a property useful because deserialization --- of objects with unused embedded DBRef's do not need to marshall them eagerly. --- Tbis also avoid unnecesary cache lookups of the pointed objects. -{-# NOINLINE getDBRef #-} -getDBRef :: (Typeable a, IResource a) => String -> DBRef a -getDBRef key= unsafePerformIO $! getDBRef1 $! key where - getDBRef1 :: (Typeable a, IResource a) => String -> IO (DBRef a) - getDBRef1 key = do - (cache,_) <- readIORef refcache -- !> ("getDBRef "++ key) - takeMVar getRefFlag - r <- H.lookup cache key - case r of - Just (CacheElem mdb w) -> do - putMVar getRefFlag () - mr <- deRefWeak w - case mr of - Just dbref@(DBRef _ tv) -> - case mdb of - Nothing -> return $! castErr dbref -- !> "just" - Just _ -> do - H.insert cache key (CacheElem Nothing w) --to notify when the DBREf leave its reference - return $! castErr dbref - Nothing -> finalize w >> getDBRef1 key -- !> "finalize" -- the weak pointer has not executed his finalizer - - Nothing -> do - tv <- newTVarIO NotRead -- !> "Nothing" - dbref <- evaluate $ DBRef key tv - w <- mkWeakPtr dbref . Just $ fixToCache dbref - H.insert cache key (CacheElem Nothing w) - putMVar getRefFlag () - return dbref - -{-# NOINLINE getRefFlag #-} -getRefFlag= unsafePerformIO $ newMVar () - -{- | Create the object passed as parameter (if it does not exist) and --- return its reference in the IO monad. --- If an object with the same key already exists, it is returned as is --- If not, the reference is created with the new value. --- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined -newDBRefIO :: (IResource a,Typeable a) => a -> IO (DBRef a) -newDBRefIO x= do - let key = keyResource x - mdbref <- mDBRefIO key - case mdbref of - Right dbref -> return dbref - - Left cache -> do - tv<- newTVarIO DoNotExist - let dbref= DBRef key tv - w <- mkWeakPtr dbref . Just $ fixToCache dbref - H.insert cache key (CacheElem Nothing w) - t <- timeInteger - atomically $ do - applyTriggers [dbref] [Just x] --`debug` ("before "++key) - writeTVar tv . Exist $ Elem x t t - return dbref - --} - - ----- get a single DBRef if exist ---mDBRefIO --- :: (IResource a, Typeable a) --- => String -- ^ the list of partial object definitions for which keyResource can be extracted --- -> IO (Either Ht (DBRef a)) -- ^ ThTCache.hse TVars that contain such objects ---mDBRefIO k= do --- (cache,_) <- readIORef refcache --- r <- H.lookup cache k --- case r of --- Just (CacheElem _ w) -> do --- mr <- deRefWeak w --- case mr of --- Just dbref -> return . Right $! castErr dbref --- Nothing -> finalize w >> mDBRefIO k --- Nothing -> return $ Left cache - - - --- | Create the object passed as parameter (if it does not exist) and --- return its reference in the STM monad. --- If an object with the same key already exists, it is returned as is --- If not, the reference is created with the new value. --- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined --- if you need to create the reference and the reference content, use 'newDBRef' -{-# NOINLINE newDBRef #-} -newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) -newDBRef x = do - let ref= getDBRef $! keyResource x - - mr <- readDBRef ref - case mr of - Nothing -> writeDBRef ref x >> return ref -- !> " write" - Just r -> return ref -- !> " non write" - ---newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) ---newDBRef x = do --- let key= keyResource x --- mdbref <- unsafeIOToSTM $ mDBRefIO key --- case mdbref of --- Right dbref -> return dbref --- Left cache -> do --- t <- unsafeIOToSTM timeInteger --- tv <- newTVar DoNotExist --- let dbref= DBRef key tv --- (cache,_) <- unsafeIOToSTM $ readIORef refcache --- applyTriggers [dbref] [Just x] --- writeTVar tv . Exist $ Elem x t t --- unsafeIOToSTM $ do --- w <- mkWeakPtr dbref . Just $ fixToCache dbref --- H.insert cache key ( CacheElem Nothing w) --- return dbref - --- | Delete the content of the DBRef form the cache and from permanent storage -delDBRef :: (IResource a, Typeable a) => DBRef a -> STM() -delDBRef dbref@(DBRef k tv)= do - mr <- readDBRef dbref - case mr of - Just x -> do - applyTriggers [dbref] [Nothing] - writeTVar tv DoNotExist - - safeIOToSTM . criticalSection saving $ delResource x - - Nothing -> return () - - - --- | Handles Nothing cases in a simpler way than runMaybeT. --- it is used in infix notation. for example: --- --- @result <- readDBRef ref \`onNothing\` error (\"Not found \"++ keyObjDBRef ref)@ --- --- or --- --- @result <- readDBRef ref \`onNothing\` return someDefaultValue@ -onNothing io onerr= do - my <- io - case my of - Just y -> return y - Nothing -> onerr - --- | Deletes the pointed object from the cache, not the database (see 'delDBRef') --- useful for cache invalidation when the database is modified by other process -flushDBRef :: (IResource a, Typeable a) =>DBRef a -> STM() -flushDBRef (DBRef _ tv)= writeTVar tv NotRead - --- | flush the element with the given key -flushKey key= do - (cache,time) <- unsafeIOToSTM $ readIORef refcache - c <- unsafeIOToSTM $ H.lookup cache key - case c of - Just (CacheElem _ w) -> do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just (DBRef k tv) -> writeTVar tv NotRead - Nothing -> unsafeIOToSTM (finalize w) >> flushKey key - Nothing -> return () - --- | label the object as not existent in database -invalidateKey key= do - (cache,time) <- unsafeIOToSTM $ readIORef refcache - c <- unsafeIOToSTM $ H.lookup cache key - case c of - Just (CacheElem _ w) -> do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just (DBRef k tv) -> writeTVar tv DoNotExist - Nothing -> unsafeIOToSTM (finalize w) >> flushKey key - Nothing -> return () - - --- | drops the entire cache. -flushAll :: STM () -flushAll = do - (cache,time) <- unsafeIOToSTM $ readIORef refcache - elms <- unsafeIOToSTM $ H.toList cache - mapM_ (del cache) elms - where - del cache ( _ , CacheElem _ w)= do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just (DBRef _ tv) -> writeTVar tv NotRead - Nothing -> unsafeIOToSTM (finalize w) - - - --- | This is the main function for the *Resource(s) calls. All the rest derive from it. The results are kept in the STM monad --- so it can be part of a larger STM transaction involving other DBRefs. --- The 'Resources' register returned by the user-defined function is interpreted as such: --- --- * 'toAdd': the content of this field will be added/updated to the cache --- --- * 'toDelete': the content of this field will be removed from the cache and from permanent storage --- --- * 'toReturn': the content of this field will be returned by 'withSTMResources' --- --- WARNING: To catch evaluations errors at the right place, the values to be written must be fully evaluated. --- Errors in delayed evaluations at serialization time can cause inconsistencies in the database. - -withSTMResources :: (IResource a, Typeable a)=> [a] -- ^ the list of resources to be retrieved - -> ([Maybe a]-> Resources a x) -- ^ The function that process the resources found and return a Resources structure - -> STM x -- ^ The return value in the STM monad. - -withSTMResources rs f= do - (cache,_) <- unsafeIOToSTM $ readIORef refcache - mtrs <- takeDBRefs rs cache AddToHash - - mrs <- mapM mreadDBRef mtrs - case f mrs of - Retry -> retry - Resources as ds r -> do - applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing `asTypeOf` (Just(head ds)))) - delListFromHash cache ds - releaseTPVars as cache - - safeIOToSTM . criticalSection saving $ mapM_ delResource ds - return r - - where - mreadDBRef :: (IResource a, Typeable a) => Maybe (DBRef a) -> STM (Maybe a) - mreadDBRef (Just dbref)= readDBRef dbref - mreadDBRef Nothing = return Nothing - - --- | Update of a single object in the cache --- --- @withResource r f= 'withResources' [r] (\[mr]-> [f mr])@ -{-# INLINE withResource #-} -withResource:: (IResource a, Typeable a) => a -> (Maybe a-> a) -> IO () -withResource r f= withResources [r] (\[mr]-> [f mr]) - - --- | To atomically add/modify many objects in the cache --- --- @ withResources rs f= atomically $ 'withSTMResources' rs f1 >> return() where f1 mrs= let as= f mrs in Resources as [] ()@ -{-# INLINE withResources #-} -withResources:: (IResource a,Typeable a)=> [a]-> ([Maybe a]-> [a])-> IO () -withResources rs f= atomically $ withSTMResources rs f1 >> return() where - f1 mrs= let as= f mrs in Resources as [] () - --- | To read a resource from the cache. --- --- @getResource r= do{mr<- 'getResources' [r];return $! head mr}@ -{-# INLINE getResource #-} -getResource:: (IResource a, Typeable a)=>a-> IO (Maybe a) -getResource r= do{mr<- getResources [r];return $! head mr} - --- | To read a list of resources from the cache if they exist --- --- | @getResources rs= atomically $ 'withSTMResources' rs f1 where f1 mrs= Resources [] [] mrs@ -{-# INLINE getResources #-} -getResources:: (IResource a, Typeable a)=>[a]-> IO [Maybe a] -getResources rs= atomically $ withSTMResources rs f1 where - f1 mrs= Resources [] [] mrs - - --- | Delete the resource from cache and from persistent storage. --- --- @ deleteResource r= 'deleteResources' [r] @ -{-# INLINE deleteResource #-} -deleteResource :: (IResource a, Typeable a) => a -> IO () -deleteResource r= deleteResources [r] - --- | Delete the list of resources from cache and from persistent storage. --- --- @ deleteResources rs= atomically $ 'withSTMResources' rs f1 where f1 mrs = Resources [] (catMaybes mrs) ()@ -{-# INLINE deleteResources #-} -deleteResources :: (IResource a, Typeable a) => [a] -> IO () -deleteResources rs= atomically $ withSTMResources rs f1 where - f1 mrs = resources {toDelete=catMaybes mrs} - -{-# INLINE takeDBRefs #-} -takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht -> CheckTPVarFlags -> STM [Maybe (DBRef a)] -takeDBRefs rs cache addToHash= mapM (takeDBRef cache addToHash) rs - - -{-# NOINLINE takeDBRef #-} -takeDBRef :: (IResource a, Typeable a) => Ht -> CheckTPVarFlags -> a -> STM(Maybe (DBRef a)) -takeDBRef cache flags x =do - let keyr= keyResource x - c <- unsafeIOToSTM $ H.lookup cache keyr - case c of - Just (CacheElem _ w) -> do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just dbref -> return . Just $! castErr dbref - Nothing -> unsafeIOToSTM (finalize w) >> takeDBRef cache flags x - Nothing -> do - safeIOToSTM $ readToCache flags cache keyr - -- unsafeIOToSTM $ readResourceByKey keyr - - where - readToCache flags cache key= do - mr <- readResource x - case mr of - Nothing -> return Nothing - Just r2 -> do - ti <- timeInteger - tvr <- newTVarIO . Exist $ Elem r2 ti (-1) - case flags of - NoAddToHash -> return . Just $ DBRef key tvr - AddToHash -> do - dbref <- evaluate $ DBRef key tvr - w <- mkWeakPtr dbref . Just $ fixToCache dbref - H.insert cache key (CacheElem (Just dbref) w) - return $ Just dbref - -- !> ("readToCache "++ key) - - - -timeInteger= do TOD t _ <- getClockTime - return t - - - - - -releaseTPVars :: (IResource a,Typeable a)=> [a] -> Ht -> STM () -releaseTPVars rs cache = mapM_ (releaseTPVar cache) rs - -releaseTPVar :: (IResource a,Typeable a)=> Ht -> a -> STM () -releaseTPVar cache r =do - c <- unsafeIOToSTM $ H.lookup cache keyr - case c of - Just (CacheElem _ w) -> do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Nothing -> unsafeIOToSTM (finalize w) >> releaseTPVar cache r - Just dbref@(DBRef key tv) -> do - applyTriggers [dbref] [Just (castErr r)] - t <- unsafeIOToSTM timeInteger - writeTVar tv . Exist $ Elem (castErr r) t t - - - Nothing -> do - ti <- unsafeIOToSTM timeInteger - tvr <- newTVar NotRead - dbref <- unsafeIOToSTM . evaluate $ DBRef keyr tvr - applyTriggers [dbref] [Just r] - writeTVar tvr . Exist $ Elem r ti ti - w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ fixToCache dbref - unsafeIOToSTM $ H.insert cache keyr (CacheElem (Just dbref) w)-- accesed and modified XXX - return () - - - where keyr= keyResource r - - - - -delListFromHash :: IResource a => Ht -> [a] -> STM () -delListFromHash cache xs= mapM_ del xs - where - del :: IResource a => a -> STM () - del x= do - let key= keyResource x - mr <- unsafeIOToSTM $ H.lookup cache key - case mr of - Nothing -> return () - Just (CacheElem _ w) -> do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Just dbref@(DBRef _ tv) -> do - writeTVar tv DoNotExist - Nothing -> do - unsafeIOToSTM (finalize w) >> del x - - - -updateListToHash hash kv= mapM (update1 hash) kv where - update1 h (k,v)= H.insert h k v - - - --- | Start the thread that periodically call `clearSyncCache` to clean and writes on the persistent storage. --- it is indirecly set by means of `syncWrite`, since it is more higuer level. I recommend to use the latter --- Otherwise, 'syncCache' or `clearSyncCache` or `atomicallySync` must be invoked explicitly or no persistence will exist. --- Cache writes allways save a coherent state -clearSyncCacheProc :: - Int -- ^ number of seconds betwen checks. objects not written to disk are written - -> (Integer -> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example - -> Int -- ^ The max number of objects in the cache, if more, the cleanup starts - -> IO ThreadId -- ^ Identifier of the thread created -clearSyncCacheProc time check sizeObjects= forkIO clear - where - clear = do - threadDelay $ time * 1000000 - handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do - clearSyncCache check sizeObjects -- !> "CLEAR" - clear - -criticalSection mv f= bracket - (takeMVar mv) - (putMVar mv) - $ const $ f - --- | Force the atomic write of all cached objects modified since the last save into permanent storage. --- Cache writes allways save a coherent state. As allways, only the modified objects are written. -syncCache :: IO () -syncCache = criticalSection saving $ do - (cache,lastSync) <- readIORef refcache --`debug` "syncCache" - t2<- timeInteger - elems <- H.toList cache - (tosave,_,_) <- atomically $ extract elems lastSync - save tosave - writeIORef refcache (cache, t2) - - -data SyncMode= Synchronous -- ^ sync state to permanent storage when `atomicallySync` is invoked - | Asyncronous - {frecuency :: Int -- ^ number of seconds between saves when asyncronous - ,check :: (Integer-> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example - ,cacheSize :: Int -- ^ size of the cache when async - } - | SyncManual -- ^ use `syncCache` to write the state - - - -{-# NOINLINE tvSyncWrite #-} -tvSyncWrite= unsafePerformIO $ newIORef (Synchronous, Nothing) - --- | Specify the cache synchronization policy with permanent storage. See `SyncMode` for details -syncWrite:: SyncMode -> IO() -syncWrite mode= do - (_,thread) <- readIORef tvSyncWrite - when (isJust thread ) $ killThread . fromJust $ thread - case mode of - Synchronous -> modeWrite - SyncManual -> modeWrite - Asyncronous time check maxsize -> do - th <- clearSyncCacheProc time check maxsize >> return() - writeIORef tvSyncWrite (mode,Just th) - where - modeWrite= writeIORef tvSyncWrite (mode, Nothing) - - --- | Perform a synchronization of the cache with permanent storage once executed the STM transaction --- when 'syncWrite' policy is `Synchronous` -atomicallySync :: STM a -> IO a -atomicallySync proc=do - r <- atomically proc - sync - return r - - where - sync= do - (savetype,_) <- readIORef tvSyncWrite - case savetype of - Synchronous -> do - syncCache - _ -> return () - - --- |Saves the unsaved elems of the cache. --- Cache writes allways save a coherent state. --- Unlike `syncChace` this call deletes some elems of the cache when the number of elems > @sizeObjects@. --- The deletion depends on the check criteria, expressed by the first parameter. --- 'defaultCheck' is the one implemented to be passed by default. Look at it to understand the clearing criteria. -clearSyncCache :: (Integer -> Integer-> Integer-> Bool)-> Int -> IO () -clearSyncCache check sizeObjects= criticalSection saving $ do - (cache,lastSync) <- readIORef refcache - t <- timeInteger - elems <- H.toList cache - (tosave, elems, size) <- atomically $ extract elems lastSync - save tosave - when (size > sizeObjects) $ forkIO (filtercache t cache lastSync elems) >> performGC - writeIORef refcache (cache, t) - - - where - - -- delete elems from the cache according with the checking criteria - filtercache t cache lastSync elems= mapM_ filter elems - where - filter (CacheElem Nothing w)= return() --alive because the dbref is being referenced elsewere - filter (CacheElem (Just (DBRef key _)) w) = do - mr <- deRefWeak w - case mr of - Nothing -> finalize w - Just (DBRef _ tv) -> atomically $ do - r <- readTVar tv - case r of - Exist (Elem x lastAccess _ ) -> - if check t lastAccess lastSync - then do - unsafeIOToSTM . H.insert cache key $ CacheElem Nothing w - writeTVar tv NotRead - else return () - _ -> return() - - - --- | This is a default cache clearance check. It forces to drop from the cache all the --- elems not accesed since half the time between now and the last sync --- if it returns True, the object will be discarded from the cache --- it is invoked when the cache size exceeds the number of objects configured --- in 'clearSyncCacheProc' or 'clearSyncCache' -defaultCheck - :: Integer -- ^ current time in seconds - -> Integer -- ^ last access time for a given object - -> Integer -- ^ last cache syncronization (with the persisten storage) - -> Bool -- ^ return true for all the elems not accesed since half the time between now and the last sync -defaultCheck now lastAccess lastSync - | lastAccess > halftime = False - | otherwise = True - - where - halftime= now- (now-lastSync) `div` 2 - -{-# NOINLINE refConditions #-} -refConditions= unsafePerformIO $ newIORef (return(), return()) - -setConditions :: IO() -> IO() -> IO() --- ^ stablishes the procedures to call before and after saving with 'syncCache', 'clearSyncCache' or 'clearSyncCacheProc'. The postcondition of --- database persistence should be a commit. -setConditions pre post= writeIORef refConditions (pre, post) - -{-# NOINLINE saving #-} -saving= unsafePerformIO $ newMVar False - -save tosave = do - (pre, post) <- readIORef refConditions - pre -- !> (concatMap (\(Filtered x) -> keyResource x)tosave) - mapM (\(Filtered x) -> writeResource x) tosave - post - - -data Filtered= forall a.(IResource a)=> Filtered a - - -extract elems lastSave= filter1 [] [] (0:: Int) elems - where - filter1 sav val n []= return (sav, val, n) - filter1 sav val n ((_, ch@(CacheElem mybe w)):rest)= do - mr <- unsafeIOToSTM $ deRefWeak w - case mr of - Nothing -> unsafeIOToSTM (finalize w) >> filter1 sav val n rest - Just (DBRef key tvr) -> - let tofilter = case mybe of - Just _ -> ch:val - Nothing -> val - in do - r <- readTVar tvr - case r of - Exist (Elem r _ modTime) -> - if (modTime >= lastSave) - then filter1 (Filtered r:sav) tofilter (n+1) rest - else filter1 sav tofilter (n+1) rest -- !> ("rejected->" ++ keyResource r) - - _ -> filter1 sav tofilter (n+1) rest - - --- | Assures that the IO computation finalizes no matter if the STM transaction --- is aborted or retried. The IO computation run in a different thread. --- The STM transaction wait until the completion of the IO procedure (or retry as usual). --- --- It can be retried if the embedding STM computation is retried --- so the IO computation must be idempotent. --- Exceptions are bubbled up to the STM transaction -safeIOToSTM :: IO a -> STM a -safeIOToSTM req= unsafeIOToSTM $ do - tv <- newEmptyMVar - forkIO $ (req >>= putMVar tv . Right) - `Control.Exception.catch` - (\(e :: SomeException) -> putMVar tv $ Left e ) - r <- takeMVar tv - case r of - Right x -> return x - Left e -> throw e - - - +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, + FlexibleInstances, UndecidableInstances #-} + +{- | TCache is a transactional cache with configurable persistence that permits +STM transactions with objects that synchronize synchronously or asynchronously with +their user defined storages. Persistence in files is provided by default. + + TCache implements 'DBRef's . They are persistent STM references with a typical Haskell interface. +similar to TVars ('newDBRef', 'readDBRef', 'writeDBRef' etc) but with added persistence. +DBRefs are serializable, so they can be stored and retrieved. +Because they are references, they point to other serializable registers. +This permits persistent mutable inter-object relations. + +For simple transactions of lists of objects of the same type TCache implements +inversion of control primitives 'withSTMResources' and variants, that call pure user-defined code for registers update. Examples below. + +Triggers in "Data.TCache.Triggers" are user-defined hooks that are called on register updates. +They are used internally for indexing. + +"Data.TCache.IndexQuery" implements a straightforward pure Haskell, type-safe query language based + on register field relations. This module must be imported separately. + +"Data.TCache.IndexText" add full text search and content search to the query language. + +"Data.TCache.DefaultPersistence" has instances for key indexation, serialization + and default file persistence. The file persistence is more reliable, and the embedded IO reads inside STM transactions are safe. + +"Data.Persistent.Collection" implements a persistent, transactional collection with Queue interface as well as indexed access by key. + +-} + + + + +module Data.TCache ( +-- * Inherited from 'Control.Concurrent.STM' and variations + + atomically + ,atomicallySync + ,STM + ,unsafeIOToSTM + ,safeIOToSTM + +-- * Operations with cached database references +{-| 'DBRef's are persistent cached database references in the STM monad +with read/write primitives, so the traditional syntax of Haskell STM references +can be used for interfacing with databases. As expected, the DBRefs are transactional, + because they operate in the STM monad. + +A @DBRef@ is associated with its referred object trough its key. +Since DBRefs are serializable, they can be elements of mutable cached objects themselves. +They could point to other mutable objects +and so on, so DBRefs can act as \"hardwired\" relations from mutable objects +to other mutable objects in the database/cache. their referred objects are loaded, saved and flushed +to and from the cache automatically depending on the cache handling policies and the access needs. + +@DBRefs@ are univocally identified by its referenced object keys, so they can be compared, ordered, checked for equality, and so on. +The creation of a DBRef, though 'getDBRef' is pure. This permits an efficient lazy access to the + registers through their DBRefs by lazy marshalling of the register content on demand. + +Example: Car registers have references to Person registers. + +@ +data Person= Person {pname :: String} deriving (Show, Read, Eq, Typeable) +data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable) +@ + +Here the Car register point to the Person register through the owner field. + +To permit persistence and being referred with DBRefs, define the 'Indexable' instance +for these two register types: + +@ +instance Indexable Person where key Person{pname= n} = "Person " ++ n +instance Indexable Car where key Car{cname= n} = "Car " ++ n +@ + +Now we create a DBRef to a Person whose name is \"Bruce\" + +>>> let bruce = getDBRef . key $ Person "Bruce" :: DBRef Person + +>>> show bruce +>"DBRef \"Person bruce\"" + +>>> atomically (readDBRef bruce) +>Nothing + +'getDBRef' is pure and creates the reference, but not the referred object; +To create both the reference and the DBRef, use 'newDBRef'. +Lets create two Cars and its two Car DBRefs with bruce as owner: + +>>> cars <- atomically $ mapM newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"] + +>>> print cars +>[DBRef "Car Bat Mobile",DBRef "Car Porsche"] + +>>> carRegs<- atomically $ mapM readDBRef cars +> [Just (Car {owner = DBRef "Person bruce", cname = "Bat Mobile"}) +> ,Just (Car {owner = DBRef "Person bruce", cname = "Porsche"})] + +try to write with 'writeDBRef': + +>>> atomically . writeDBRef bruce $ Person "Other" +>*** Exception: writeDBRef: law of key conservation broken: old , new= Person bruce , Person Other + +DBRef's can not be written with objects of different keys: + +>>> atomically . writeDBRef bruce $ Person "Bruce" + +>>> let Just carReg1= head carRegs + +now from the Car register it is possible to recover the owner's register: + +>>> atomically $ readDBRef ( owner carReg1) +>Just (Person {pname = "bruce"}) + +DBRefs, once the referenced, cached object is looked up in the cache and found at creation, do +not perform any further cache lookup afterwards, so reads and writes from/to DBRefs are faster +than *Resource(s) calls, which perform cache lookups every time the object is accessed. + +DBRefs and @*Resource(s)@ primitives are completely interoperable. The latter operate implicitly with DBRefs + +-} + + +,DBRef +,getDBRef +,keyObjDBRef +,newDBRef +--,newDBRefIO +,readDBRef +,readDBRefs +,writeDBRef +,delDBRef + +-- * @IResource@ class +{- | Cached objects must be instances of `IResource`. +Such instances can be implicitly derived trough auxiliary classes for file persistence. +-} +,IResource(..) + +-- * Operations with cached objects +{- | Implement inversion of control primitives where the user defines the objects to retrieve. The primitives +then call the defined function that determines how to transform the retrieved objects, which are sent +back to the storage and a result is returned. + +In this example \"buy\" is a transaction where the user buys an item. +The spent amount is increased and the stock of the product is decreased: + +@ +data Data= User{uname:: String, uid:: String, spent:: Int} | + Item{iname:: String, iid:: String, price:: Int, stock:: Int} + deriving (Read, Show) + +instance `Indexable` Data where + `key` User{uid=id}= id + `key` Item{iid=id}= id + +user `buy` item= 'withResources'[user,item] buyIt + where + buyIt[Just us,Just it] + | stock it > 0= [us',it'] + | otherwise = error \"stock is empty for this product\" + where + us'= us{spent=spent us + price it} + it'= it{stock= stock it-1} + buyIt _ = error \"either the user or the item (or both) does not exist\" +@ +-} +,Resources(..) -- data definition used to communicate object Inserts and Deletes to the cache +,resources -- empty resources +,withSTMResources +,withResources +,withResource +,getResources +,getResource +,deleteResources +,deleteResource + +-- * Trigger operations +{- | Trriggers are called just before an object of the given type is created, modified or deleted. +The DBRef to the object and the new value is passed to the trigger. +The called trigger function has two parameters: the DBRef being accesed +(which still contains the old value), and the new value. +If the content of the DBRef is being deleted, the second parameter is 'Nothing'. +if the DBRef contains Nothing, then the object is being created + +Example: + +Every time a car is added, or deleted, the owner's list is updated. +This is done by the user defined trigger addCar + +@ + addCar pcar (Just(Car powner _ )) = addToOwner powner pcar + addCar pcar Nothing = readDBRef pcar >>= \\(Just car)-> deleteOwner (owner car) pcar + + addToOwner powner pcar=do + Just owner <- readDBRef powner + writeDBRef powner owner{cars= nub $ pcar : cars owner} + + deleteOwner powner pcar= do + Just owner <- readDBRef powner + writeDBRef powner owner{cars= delete pcar $ cars owner} + + main= do + 'addTrigger' addCar + putStrLn \"create bruce's register with no cars\" + bruce \<- 'atomically' 'newDBRef' $ Person \"Bruce\" [] + putStrLn \"add two car register with \\"bruce\\" as owner using the reference to the bruces register\" + let newcars= [Car bruce \"Bat Mobile\" , Car bruce \"Porsche\"] + insert newcars + Just bruceData \<- atomically $ 'readDBRef' bruce + putStrLn \"the trigger automatically updated the car references of the Bruce register\" + print . length $ cars bruceData + print bruceData +@ + +gives: + +> main +> 2 +> Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]} + +-} + +,addTrigger + +-- * Cache control +{-- | + +The mechanism for dropping elements from the cache is too lazy. `flushDBRef`, for example +just delete the data element from the TVar, but the TVar node +remains attached to the table so there is no decrement on the number of elements. +The element is garbage collected unless you have a direct reference to the element, not the DBRef +Note that you can still have a valid reference to this element, but this element is no longer +in the cache. The usual thing is that you do not have it, and the element will be garbage +collected (but still there will be a NotRead entry for this key!!!). If the DBRef is read again, the +TCache will go to permanent storage to retrieve it. + +clear opertions such `clearsyncCache` does something similar: it does not delete the +element from the cache. It just inform the garbage collector that there is no longer necessary to maintain +the element in the cache. So if the element has no other references (maybe you keep a +variable that point to that DBRef) it will be GCollected. +If this is not possible, it will remain in the cache and will be treated as such, +until the DBRef is no longer referenced by the program. This is done by means of a weak pointer + +All these complications are necessary because the programmer can handle DBRefs directly, +so the cache has no complete control of the DBRef life cycle, short to speak. + +a DBRef can be in the states: + +- `Exist`: it is in the cache + +- `DoesNotExist`: neither is in the cache neither in storage: it is like a cached "notfound" to +speed up repeated failed requests + +- `NotRead`: may exist or not in permanent storage, but not in the cache + + +In terms of Garbage collection it may be: + + + +1 - pending garbage collection: attached to the hashtable by means of a weak pointer: delete it asap + +2 - cached: attached by a direct pointer and a weak pointer: It is being cached + + +clearsyncCache just pass elements from 2 to 1 + +--} +,flushDBRef +,flushKey +,invalidateKey +,flushAll +,Cache +,setCache +,newCache +--,refcache +,syncCache +,setConditions +,clearSyncCache +,numElems +,statElems +,syncWrite +,SyncMode(..) +,clearSyncCacheProc +,defaultCheck +-- * Other +,onNothing +) +where + + +import GHC.Conc +import GHC.MVar(MVar) +import Control.Monad(when, void) +import qualified Data.HashTable.IO as H(BasicHashTable, new, insert, lookup, toList) +import Data.IORef(IORef, newIORef, readIORef, writeIORef) +import System.IO.Unsafe(unsafePerformIO) +import System.IO(hPutStr, stderr) +import Data.Maybe(catMaybes) +import Data.Foldable(forM_) +import Data.Char(isSpace) +import Data.TCache.Defs +import Data.TCache.IResource +import Data.TCache.Triggers +import Data.Typeable(Typeable) +import System.Time(getClockTime, ClockTime(TOD)) +import System.Mem(performGC) +import System.Mem.Weak(Weak, deRefWeak, mkWeakPtr, finalize) + +import Control.Concurrent.MVar(newMVar, newEmptyMVar, takeMVar, putMVar) +import Control.Exception(catch, handle, throw, evaluate, bracket, SomeException) + +--import Debug.Trace +--(!>) = flip trace + +-- there are two references to the DBRef here +-- The Maybe one keeps it alive until the cache releases it for *Resources +-- calls which does not reference dbrefs explicitly +-- The weak reference keeps the dbref alive until is it not referenced elsewere +data CacheElem= forall a.(IResource a,Typeable a) => CacheElem (Maybe (DBRef a)) (Weak(DBRef a)) + +type Ht = H.BasicHashTable String CacheElem + +-- contains the hastable, last sync time +type Cache = IORef (Ht , Integer) +data CheckTPVarFlags= AddToHash | NoAddToHash + +-- | Set the cache. this is useful for hot loaded modules that will update an existing cache. Experimental +setCache :: Cache -> IO() +setCache ref = readIORef ref >>= \ch -> writeIORef refcache ch + +-- | The cache holder. established by default +refcache :: Cache +{-# NOINLINE refcache #-} +refcache =unsafePerformIO $ newCache >>= newIORef + +-- | Creates a new cache. Experimental +newCache :: IO (Ht , Integer) +newCache =do + c <- H.new -- (==) H.hashString + return (c,0) + +-- | Return the total number of DBRefs in the cache. For debug purposes. +-- This does not count the number of objects in the cache since many of the 'DBRef's +-- may not have the referenced object loaded. It's O(n). +numElems :: IO Int +numElems= do + (cache, _) <- readIORef refcache + elems <- H.toList cache + return $ length elems + + +-- | Retuns some statistical information for the DBRefs in the cache (for debugging) +-- This returns a tuple containing: +-- total : count of the total elements in cache +-- dirty : the elements which need to be written to the persistent storage +-- loaded : the elements which are currently hold in memory +statElems :: IO (Int, Int, Int) +statElems = do + (cache, lastSync) <- readIORef refcache + clist <- H.toList cache + (tosave, elems, size) <- atomically $ extract clist lastSync + counted <- mapM count elems + return (size, length tosave, sum counted) + where + count (CacheElem _ w) = do + mr <- deRefWeak w + case mr of + Just (DBRef _ tv) -> do + r <- readTVarIO tv + case r of + Exist Elem {} -> return 1 + DoNotExist -> return 0 + NotRead -> return 0 + Nothing -> finalize w >> return 0 + +-- deRefWeakSTM = unsafeIOToSTM . deRefWeak + +--deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO () +--deleteFromCache (DBRef k tv)= do +-- (cache, _) <- readIORef refcache +-- H.delete cache k -- !> ("delete " ++ k) + +fixToCache :: (IResource a, Typeable a) => DBRef a -> IO () +fixToCache dbref@(DBRef k _)= do + (cache, _) <- readIORef refcache + w <- mkWeakPtr dbref $ Just $ fixToCache dbref + H.insert cache k (CacheElem (Just dbref) w) + return() + +-- | Return the reference value. If it is not in the cache, it is fetched +-- from the database. +readDBRef :: (IResource a, Typeable a) => DBRef a -> STM (Maybe a) +readDBRef (DBRef key1 tv)= do + r <- readTVar tv + case r of + Exist (Elem x _ mt) -> do + t <- unsafeIOToSTM timeInteger + writeTVar tv . Exist $ Elem x t mt + return $ Just x + DoNotExist -> return Nothing + NotRead -> do + r1 <- safeIOToSTM $ readResourceByKey key1 + case r1 of + Nothing -> writeTVar tv DoNotExist >> return Nothing + Just x -> do + t <- unsafeIOToSTM timeInteger + writeTVar tv $ Exist $ Elem x t (-1) + return $ Just x + +-- | Read multiple DBRefs in a single request using the new 'readResourcesByKey' +readDBRefs :: (IResource a, Typeable a) => [DBRef a] -> STM [Maybe a] +readDBRefs dbrefs= do + let mf (DBRef key1 tv)= do + r <- readTVar tv + case r of + Exist (Elem x _ mt) -> do + t <- unsafeIOToSTM timeInteger + writeTVar tv . Exist $ Elem x t mt + return $ Right $ Just x + DoNotExist -> return $ Right Nothing + NotRead -> return $ Left key1 + inCache <- mapM mf dbrefs + let pairs = foldr(\pair@(x,_) xs -> case x of Left _ -> pair:xs; _ -> xs ) [] $ zip inCache dbrefs + let (toReadKeys, dbrs) = unzip pairs + let fromLeft (Left k)= k + fromLeft _ = error "this will never happen" + rs <- safeIOToSTM . readResourcesByKey $ map fromLeft toReadKeys + let processTVar (r, DBRef _ tv)= + case r of + Nothing -> writeTVar tv DoNotExist + Just x -> do + t <- unsafeIOToSTM timeInteger + writeTVar tv $ Exist $ Elem x t (-1) + + mapM_ processTVar $ zip rs dbrs + let mix (Right x:xs) ys = x:mix xs ys + mix (Left _:xs) (y:ys)= y:mix xs ys + mix [] _ = error "this will never happen(?)" + mix (Left _:_) [] = error "this will never happen(?)" + + return $ mix inCache rs + +-- | Write in the reference a value +-- The new key must be the same than the old key of the previous object stored +-- otherwise, an error "law of key conservation broken" will be raised +-- +-- WARNING: the value to be written in the DBRef must be fully evaluated. Delayed evaluations at +-- serialization time can cause inconsistencies in the database. +-- In future releases this will be enforced. +writeDBRef :: (IResource a, Typeable a) => DBRef a -> a -> STM () +writeDBRef dbref@(DBRef key1 tv) x= x `seq` do + let newkey= keyResource x + if newkey /= key1 + then error $ "writeDBRef: law of key conservation broken: old , new= " ++ key1 ++ " , "++newkey + else do + applyTriggers [dbref] [Just x] + t <- unsafeIOToSTM timeInteger + + writeTVar tv $! Exist $! Elem x t t + return() + +instance (IResource a, Typeable a) => Read (DBRef a) where + readsPrec _ str1= readit str + where + str = dropWhile isSpace str1 + readit ('D':'B':'R':'e':'f':' ':'\"':str2)= + let (key1,nstr) = break (== '\"') str2 + in [( getDBRef key1 :: DBRef a, tail nstr)] + readit _ = [] + +-- | Return the key of the object referenced by the DBRef +keyObjDBRef :: DBRef a -> String +keyObjDBRef (DBRef k _)= k + +-- | Get the reference to the object in the cache. If it does not exist, the reference is created empty. +-- Every execution of 'getDBRef' returns the same unique reference to this key, +-- so it can be safely considered pure. This property is useful because deserialization +-- of objects with unused embedded 'DBRef's do not need to marshall them eagerly. +-- This also avoids unnecessary cache lookups of the referenced objects. +{-# NOINLINE getDBRef #-} +getDBRef :: (Typeable a, IResource a) => String -> DBRef a +getDBRef key1 = unsafePerformIO $! getDBRef1 $! key1 where + getDBRef1 :: (Typeable a, IResource a) => String -> IO (DBRef a) + getDBRef1 key2 = do + (cache,_) <- readIORef refcache -- !> ("getDBRef "++ key) + takeMVar getRefFlag + r <- H.lookup cache key2 + case r of + Just (CacheElem mdb w) -> do + putMVar getRefFlag () + mr <- deRefWeak w + case mr of + Just dbref@(DBRef _ _) -> + case mdb of + Nothing -> return $! castErr dbref -- !> "just" + Just _ -> do + H.insert cache key2 (CacheElem Nothing w) --to notify when the DBREf leave its reference + return $! castErr dbref + Nothing -> finalize w >> getDBRef1 key2 -- !> "finalize" -- the weak pointer has not executed his finalizer + + Nothing -> do + tv <- newTVarIO NotRead -- !> "Nothing" + dbref <- evaluate $ DBRef key2 tv + w <- mkWeakPtr dbref . Just $ fixToCache dbref + H.insert cache key2 (CacheElem Nothing w) + putMVar getRefFlag () + return dbref + +getRefFlag :: MVar () +{-# NOINLINE getRefFlag #-} +getRefFlag= unsafePerformIO $ newMVar () + +{- | Create the object passed as parameter (if it does not exist) and +-- return its reference in the IO monad. +-- If an object with the same key already exists, it is returned as is +-- If not, the reference is created with the new value. +-- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined +newDBRefIO :: (IResource a,Typeable a) => a -> IO (DBRef a) +newDBRefIO x= do + let key = keyResource x + mdbref <- mDBRefIO key + case mdbref of + Right dbref -> return dbref + + Left cache -> do + tv<- newTVarIO DoNotExist + let dbref= DBRef key tv + w <- mkWeakPtr dbref . Just $ fixToCache dbref + H.insert cache key (CacheElem Nothing w) + t <- timeInteger + atomically $ do + applyTriggers [dbref] [Just x] --`debug` ("before "++key) + writeTVar tv . Exist $ Elem x t t + return dbref + +-} + + +---- get a single DBRef if exist +--mDBRefIO +-- :: (IResource a, Typeable a) +-- => String -- ^ the list of partial object definitions for which keyResource can be extracted +-- -> IO (Either Ht (DBRef a)) -- ^ ThTCache.hse TVars that contain such objects +--mDBRefIO k= do +-- (cache,_) <- readIORef refcache +-- r <- H.lookup cache k +-- case r of +-- Just (CacheElem _ w) -> do +-- mr <- deRefWeak w +-- case mr of +-- Just dbref -> return . Right $! castErr dbref +-- Nothing -> finalize w >> mDBRefIO k +-- Nothing -> return $ Left cache + + + +-- | Create the object passed as parameter (if it does not exist) and +-- return its reference in the STM monad. +-- If an object with the same key already exists, it is returned as is +-- If not, the reference is created with the new value. +-- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined +-- if you need to create the reference and the reference content, use 'newDBRef' +{-# NOINLINE newDBRef #-} +newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) +newDBRef x = do + let ref= getDBRef $! keyResource x + + mr <- readDBRef ref + case mr of + Nothing -> writeDBRef ref x >> return ref -- !> " write" + Just _ -> return ref -- !> " non write" + +--newDBRef :: (IResource a, Typeable a) => a -> STM (DBRef a) +--newDBRef x = do +-- let key= keyResource x +-- mdbref <- unsafeIOToSTM $ mDBRefIO key +-- case mdbref of +-- Right dbref -> return dbref +-- Left cache -> do +-- t <- unsafeIOToSTM timeInteger +-- tv <- newTVar DoNotExist +-- let dbref= DBRef key tv +-- (cache,_) <- unsafeIOToSTM $ readIORef refcache +-- applyTriggers [dbref] [Just x] +-- writeTVar tv . Exist $ Elem x t t +-- unsafeIOToSTM $ do +-- w <- mkWeakPtr dbref . Just $ fixToCache dbref +-- H.insert cache key ( CacheElem Nothing w) +-- return dbref + +-- | Delete the content of the DBRef form the cache and from permanent storage +delDBRef :: (IResource a, Typeable a) => DBRef a -> STM() +delDBRef dbref@(DBRef _ tv)= do + mr <- readDBRef dbref + case mr of + Just x -> do + applyTriggers [dbref] [Nothing] + writeTVar tv DoNotExist + + safeIOToSTM . criticalSection saving $ delResource x + + Nothing -> return () + + + +-- | Handles Nothing cases in a simpler way than runMaybeT. +-- it is used in infix notation. for example: +-- +-- @result <- readDBRef ref \`onNothing\` error (\"Not found \"++ keyObjDBRef ref)@ +-- +-- or +-- +-- @result <- readDBRef ref \`onNothing\` return someDefaultValue@ +onNothing :: Monad m => m (Maybe b) -> m b -> m b +onNothing io onerr= do + my <- io + case my of + Just y -> return y + Nothing -> onerr + +-- | Deletes the referenced object from the cache, not the database (see 'delDBRef') +-- useful for cache invalidation when the database is modified by other processes. +flushDBRef :: (IResource a, Typeable a) =>DBRef a -> STM() +flushDBRef (DBRef _ tv)= writeTVar tv NotRead + +-- | flush the element with the given key +flushKey :: String -> STM () +flushKey key1= do + (cache, _) <- unsafeIOToSTM $ readIORef refcache + c <- unsafeIOToSTM $ H.lookup cache key1 + case c of + Just (CacheElem _ w) -> do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Just (DBRef _ tv) -> writeTVar tv NotRead + Nothing -> unsafeIOToSTM (finalize w) >> flushKey key1 + Nothing -> return () + +-- | label the object as not existent in database +invalidateKey :: String -> STM () +invalidateKey key1= do + (cache, _) <- unsafeIOToSTM $ readIORef refcache + c <- unsafeIOToSTM $ H.lookup cache key1 + case c of + Just (CacheElem _ w) -> do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Just (DBRef _ tv) -> writeTVar tv DoNotExist + Nothing -> unsafeIOToSTM (finalize w) >> flushKey key1 + Nothing -> return () + + +-- | drops the entire cache. +flushAll :: STM () +flushAll = do + (cache, _) <- unsafeIOToSTM $ readIORef refcache + elms <- unsafeIOToSTM $ H.toList cache + mapM_ del elms + where + del ( _ , CacheElem _ w)= do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Just (DBRef _ tv) -> writeTVar tv NotRead + Nothing -> unsafeIOToSTM (finalize w) + + + +-- | This is the main function for the *Resource(s) calls. All the rest derive from it. The results are kept in the STM monad +-- so it can be part of a larger STM transaction involving other DBRefs. +-- The 'Resources' register returned by the user-defined function is interpreted as such: +-- +-- * 'toAdd': the content of this field will be added/updated to the cache +-- +-- * 'toDelete': the content of this field will be removed from the cache and from permanent storage +-- +-- * 'toReturn': the content of this field will be returned by 'withSTMResources' +-- +-- WARNING: To catch evaluations errors at the right place, the values to be written must be fully evaluated. +-- Errors in delayed evaluations at serialization time can cause inconsistencies in the database. + +withSTMResources :: (IResource a, Typeable a)=> [a] -- ^ the list of resources to be retrieved + -> ([Maybe a]-> Resources a x) -- ^ The function that process the resources found and return a Resources structure + -> STM x -- ^ The return value in the STM monad. + +withSTMResources rs f = do + (cache, _) <- unsafeIOToSTM $ readIORef refcache + mtrs <- takeDBRefs rs cache AddToHash + mrs <- mapM mreadDBRef mtrs + case f mrs of + Retry -> retry + Resources as ds r -> do + applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing `asTypeOf` Just (head ds))) + delListFromHash cache ds + releaseTPVars as cache + safeIOToSTM . criticalSection saving $ mapM_ delResource ds + return r + where + mreadDBRef :: (IResource a, Typeable a) => Maybe (DBRef a) -> STM (Maybe a) + mreadDBRef (Just dbref) = readDBRef dbref + mreadDBRef Nothing = return Nothing + + +-- | Update of a single object in the cache +-- +-- @withResource r f= 'withResources' [r] (\[mr]-> [f mr])@ +{-# INLINE withResource #-} +withResource:: (IResource a, Typeable a) => a -> (Maybe a-> a) -> IO () +withResource r f= withResources [r] (\[mr]-> [f mr]) + + +-- | To atomically add/modify many objects in the cache +-- +-- @ withResources rs f= atomically $ 'withSTMResources' rs f1 >> return() where f1 mrs= let as= f mrs in Resources as [] ()@ +{-# INLINE withResources #-} +withResources:: (IResource a,Typeable a)=> [a]-> ([Maybe a]-> [a])-> IO () +withResources rs f = atomically $ void (withSTMResources rs f1) + where + f1 mrs = + let as = f mrs + in Resources as [] () + +-- | To read a resource from the cache. +-- +-- @getResource r= do{mr<- 'getResources' [r];return $! head mr}@ +{-# INLINE getResource #-} +getResource:: (IResource a, Typeable a)=>a-> IO (Maybe a) +getResource r= do{mr<- getResources [r];return $! head mr} + +-- | To read a list of resources from the cache if they exist +-- +-- | @getResources rs= atomically $ 'withSTMResources' rs f1 where f1 mrs= Resources [] [] mrs@ +{-# INLINE getResources #-} +getResources:: (IResource a, Typeable a)=>[a]-> IO [Maybe a] +getResources rs= atomically $ withSTMResources rs f1 where + f1 = Resources [] [] + + +-- | Delete the resource from cache and from persistent storage. +-- +-- @ deleteResource r= 'deleteResources' [r] @ +{-# INLINE deleteResource #-} +deleteResource :: (IResource a, Typeable a) => a -> IO () +deleteResource r= deleteResources [r] + +-- | Delete the list of resources from cache and from persistent storage. +-- +-- @ deleteResources rs= atomically $ 'withSTMResources' rs f1 where f1 mrs = Resources [] (catMaybes mrs) ()@ +{-# INLINE deleteResources #-} +deleteResources :: (IResource a, Typeable a) => [a] -> IO () +deleteResources rs= atomically $ withSTMResources rs f1 where + f1 mrs = resources {toDelete=catMaybes mrs} + +{-# INLINE takeDBRefs #-} +takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht -> CheckTPVarFlags -> STM [Maybe (DBRef a)] +takeDBRefs rs cache addToHash= mapM (takeDBRef cache addToHash) rs + + +{-# NOINLINE takeDBRef #-} +takeDBRef :: (IResource a, Typeable a) => Ht -> CheckTPVarFlags -> a -> STM(Maybe (DBRef a)) +takeDBRef cache flags x =do + let keyr= keyResource x + c <- unsafeIOToSTM $ H.lookup cache keyr + case c of + Just (CacheElem _ w) -> do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Just dbref -> return . Just $! castErr dbref + Nothing -> unsafeIOToSTM (finalize w) >> takeDBRef cache flags x + Nothing -> + safeIOToSTM $ readToCache flags cache keyr + -- unsafeIOToSTM $ readResourceByKey keyr + + where + readToCache flags1 cache1 key1= do + mr <- readResource x + case mr of + Nothing -> return Nothing + Just r2 -> do + ti <- timeInteger + tvr <- newTVarIO . Exist $ Elem r2 ti (-1) + case flags1 of + NoAddToHash -> return . Just $ DBRef key1 tvr + AddToHash -> do + dbref <- evaluate $ DBRef key1 tvr + w <- mkWeakPtr dbref . Just $ fixToCache dbref + H.insert cache1 key1 (CacheElem (Just dbref) w) + return $ Just dbref + -- !> ("readToCache "++ key) + + + +timeInteger :: IO Integer +timeInteger= do TOD t _ <- getClockTime + return t + + + + + +releaseTPVars :: (IResource a,Typeable a)=> [a] -> Ht -> STM () +releaseTPVars rs cache = mapM_ (releaseTPVar cache) rs + +releaseTPVar :: (IResource a,Typeable a)=> Ht -> a -> STM () +releaseTPVar cache r =do + c <- unsafeIOToSTM $ H.lookup cache keyr + case c of + Just (CacheElem _ w) -> do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Nothing -> unsafeIOToSTM (finalize w) >> releaseTPVar cache r + Just dbref@(DBRef _ tv) -> do + applyTriggers [dbref] [Just (castErr r)] + t <- unsafeIOToSTM timeInteger + writeTVar tv . Exist $ Elem (castErr r) t t + + + Nothing -> do + ti <- unsafeIOToSTM timeInteger + tvr <- newTVar NotRead + dbref <- unsafeIOToSTM . evaluate $ DBRef keyr tvr + applyTriggers [dbref] [Just r] + writeTVar tvr . Exist $ Elem r ti ti + w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ fixToCache dbref + unsafeIOToSTM $ H.insert cache keyr (CacheElem (Just dbref) w)-- accesed and modified XXX + return () + + + where keyr= keyResource r + + + + +delListFromHash :: IResource a => Ht -> [a] -> STM () +delListFromHash cache= mapM_ del + where + del :: IResource a => a -> STM () + del x= do + let key1= keyResource x + mr <- unsafeIOToSTM $ H.lookup cache key1 + case mr of + Nothing -> return () + Just (CacheElem _ w) -> do + mr1 <- unsafeIOToSTM $ deRefWeak w + case mr1 of + Just (DBRef _ tv) -> + writeTVar tv DoNotExist + Nothing -> + unsafeIOToSTM (finalize w) >> del x + + +{- never used +updateListToHash hash kv= mapM (update1 hash) kv where + update1 h (k,v)= H.insert h k v +-} + + +-- | Start the thread that periodically call `clearSyncCache` to clean and writes on the persistent storage. +-- it is indirectly set by means of `syncWrite`, since it is more higuer level. I recommend to use the latter +-- Otherwise, 'syncCache' or `clearSyncCache` or `atomicallySync` must be invoked explicitly or no persistence will exist. +-- Cache writes allways save a coherent state +clearSyncCacheProc :: + Int -- ^ number of seconds betwen checks. objects not written to disk are written + -> (Integer -> Integer-> Integer-> Bool) -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example + -> Int -- ^ The max number of objects in the cache, if more, the cleanup starts + -> IO ThreadId -- ^ Identifier of the thread created +clearSyncCacheProc time check1 sizeObjects= forkIO clear + where + clear = do + threadDelay $ time * 1000000 + handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do + clearSyncCache check1 sizeObjects -- !> "CLEAR" + clear + +criticalSection :: MVar b -> IO c -> IO c +criticalSection mv f= bracket + (takeMVar mv) + (putMVar mv) + $ const f + +-- | Force the atomic write of all cached objects modified since the last save into permanent storage. +-- Cache writes allways save a coherent state. As always, only the modified objects are written. +syncCache :: IO () +syncCache = criticalSection saving $ do + (cache,lastSync) <- readIORef refcache --`debug` "syncCache" + t2<- timeInteger + elems <- H.toList cache + (tosave,_,_) <- atomically $ extract elems lastSync + save tosave + writeIORef refcache (cache, t2) + + +data SyncMode= Synchronous -- ^ sync state to permanent storage when `atomicallySync` is invoked + | Asynchronous + {frequency :: Int -- ^ number of seconds between saves when asynchronous + ,check :: Integer-> Integer-> Integer-> Bool -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example + ,cacheSize :: Int -- ^ size of the cache when async + } + | SyncManual -- ^ use `syncCache` to write the state + + + + +{-# NOINLINE tvSyncWrite #-} +tvSyncWrite :: IORef (SyncMode, Maybe a) +tvSyncWrite= unsafePerformIO $ newIORef (Synchronous, Nothing) + +-- | Specify the cache synchronization policy with permanent storage. See `SyncMode` for details +syncWrite:: SyncMode -> IO() +syncWrite mode = do + (_, thread) <- readIORef tvSyncWrite + forM_ thread killThread + case mode of + Synchronous -> modeWrite + SyncManual -> modeWrite + Asynchronous time check1 maxsize -> do + th <- void $ clearSyncCacheProc time check1 maxsize + writeIORef tvSyncWrite (mode, Just th) + where + modeWrite = writeIORef tvSyncWrite (mode, Nothing) + + +-- | Perform a synchronization of the cache with permanent storage once executed the STM transaction +-- when 'syncWrite' policy is `Synchronous` +atomicallySync :: STM a -> IO a +atomicallySync proc=do + r <- atomically proc + sync + return r + + where + sync= do + (savetype,_) <- readIORef tvSyncWrite + case savetype of + Synchronous -> syncCache + _ -> return () + + +-- |Saves the unsaved elems of the cache. +-- Cache writes allways save a coherent state. +-- Unlike `syncCache` this call deletes some elems from the cache when the number of elems > @sizeObjects@. +-- The deletion depends on the check criteria, expressed by the first parameter. +-- 'defaultCheck' is the one implemented to be passed by default. Look at it to understand the clearing criteria. +clearSyncCache :: (Integer -> Integer-> Integer-> Bool)-> Int -> IO () +clearSyncCache check1 sizeObjects= criticalSection saving $ do + (cache,lastSync) <- readIORef refcache + t <- timeInteger + elems <- H.toList cache + (tosave, elems1, size) <- atomically $ extract elems lastSync + save tosave + when (size > sizeObjects) $ forkIO (filtercache t cache lastSync elems1) >> performGC + writeIORef refcache (cache, t) + + + where + + -- delete elems from the cache according with the checking criteria + filtercache t cache lastSync = mapM_ filter1 + where + filter1 (CacheElem Nothing _)= return() --alive because the dbref is being referenced elsewere + filter1 (CacheElem (Just (DBRef key1 _)) w) = do + mr <- deRefWeak w + case mr of + Nothing -> finalize w + Just (DBRef _ tv) -> atomically $ do + r <- readTVar tv + case r of + Exist (Elem _ lastAccess _ ) -> + when (check1 t lastAccess lastSync) $ do + unsafeIOToSTM . H.insert cache key1 $ CacheElem Nothing w + writeTVar tv NotRead + _ -> return() + + + +-- | This is a default cache clearance check. It forces to drop from the cache all the +-- elems not accesed since half the time between now and the last sync +-- if it returns True, the object will be discarded from the cache +-- it is invoked when the cache size exceeds the number of objects configured +-- in 'clearSyncCacheProc' or 'clearSyncCache' +defaultCheck + :: Integer -- ^ current time in seconds + -> Integer -- ^ last access time for a given object + -> Integer -- ^ last cache synchronization (with the persisten storage) + -> Bool -- ^ return true for all the elems not accesed since half the time between now and the last sync +defaultCheck now lastAccess lastSync + | lastAccess > halftime = False + | otherwise = True + + where + halftime= now- (now-lastSync) `div` 2 + +{-# NOINLINE refConditions #-} +refConditions :: IORef (IO (), IO ()) +refConditions= unsafePerformIO $ newIORef (return(), return()) + +setConditions :: IO() -> IO() -> IO() +-- ^ stablishes the procedures to call before and after saving with 'syncCache', 'clearSyncCache' or 'clearSyncCacheProc'. The postcondition of +-- database persistence should be a commit. +setConditions pre post= writeIORef refConditions (pre, post) + +{-# NOINLINE saving #-} +saving :: MVar Bool +saving= unsafePerformIO $ newMVar False + +save :: Foldable t => t Filtered -> IO () +save tosave = do + (pre, post) <- readIORef refConditions + pre -- !> (concatMap (\(Filtered x) -> keyResource x)tosave) + mapM_ (\(Filtered x) -> writeResource x) tosave + post + + +data Filtered= forall a.(IResource a)=> Filtered a + + +extract :: [(a, CacheElem)] -> Integer -> STM ([Filtered], [CacheElem], Int) +extract elems lastSave= filter1 [] [] (0:: Int) elems + where + filter1 sav val n []= return (sav, val, n) + filter1 sav val n ((_, ch@(CacheElem mybe w)):rest)= do + mr <- unsafeIOToSTM $ deRefWeak w + case mr of + Nothing -> unsafeIOToSTM (finalize w) >> filter1 sav val n rest + Just (DBRef _ tvr) -> + let tofilter = case mybe of + Just _ -> ch:val + Nothing -> val + in do + r <- readTVar tvr + case r of + Exist (Elem r1 _ modTime) -> + if modTime >= lastSave + then filter1 (Filtered r1:sav) tofilter (n+1) rest + else filter1 sav tofilter (n+1) rest -- !> ("rejected->" ++ keyResource r) + + _ -> filter1 sav tofilter (n+1) rest + + +-- | Assures that the IO computation finalizes no matter if the STM transaction +-- is aborted or retried. The IO computation run in a different thread. +-- The STM transaction wait until the completion of the IO procedure (or retry as usual). +-- +-- It can be retried if the embedding STM computation is retried +-- so the IO computation must be idempotent. +-- Exceptions are bubbled up to the STM transaction +safeIOToSTM :: IO a -> STM a +safeIOToSTM req= unsafeIOToSTM $ do + tv <- newEmptyMVar + _ <- forkIO $ (req >>= putMVar tv . Right) + `Control.Exception.catch` + (\(e :: SomeException) -> putMVar tv $ Left e ) + r <- takeMVar tv + case r of + Right x -> return x + Left e -> throw e + diff --git a/Data/TCache/DefaultPersistence.hs b/Data/TCache/DefaultPersistence.hs --- a/Data/TCache/DefaultPersistence.hs +++ b/Data/TCache/DefaultPersistence.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances - , MultiParamTypeClasses, FunctionalDependencies - - , ExistentialQuantification - , ScopedTypeVariables - #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, + MultiParamTypeClasses, ExistentialQuantification, + ScopedTypeVariables #-} {- | This module decouples the 'IResource" class in two classes one for key extraction 'Indexable' and other ('Serializable" for serlalization and persistence @@ -20,18 +18,13 @@ ,filePersist ,Persist(..)) where -import System.IO.Unsafe import Data.Typeable -import Data.Maybe(fromJust) import Data.TCache.Defs import Data.TCache - - - instance (Typeable a, Indexable a, Serializable a) => IResource a where keyResource = key - writeResource =defWriteResource + writeResource = defWriteResource readResourceByKey = defReadResourceByKey delResource = defDelResource diff --git a/Data/TCache/Defs.hs b/Data/TCache/Defs.hs --- a/Data/TCache/Defs.hs +++ b/Data/TCache/Defs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable #-} {- | some internal definitions. To use default persistence, import @Data.TCache.DefaultPersistence@ instead -} @@ -7,43 +7,47 @@ import Data.Typeable import Control.Concurrent.STM(TVar) -import Data.TCache.IResource - import System.IO.Unsafe import Data.IORef import System.Directory -import Control.Monad(when,replicateM) import System.IO import System.IO.Error import Control.Exception as Exception -import Control.Concurrent import Data.List(elemIndices,isInfixOf) -import Data.Maybe(fromJust) +import Data.Maybe(fromJust, fromMaybe) import qualified Data.ByteString.Lazy.Char8 as B --import Debug.Trace --(!>) = flip trace - -type AccessTime = Integer -type ModifTime = Integer - -data Status a= NotRead | DoNotExist | Exist a deriving Typeable +type AccessTime = Integer +type ModifTime = Integer -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 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 + +instance Show (DBRef a) where + show (DBRef key1 _)= "DBRef \""++ key1 ++ "\"" + +instance Eq (DBRef a) where + DBRef k _ == DBRef k' _ = k == k' + +instance Ord (DBRef a) where + compare (DBRef k _) (DBRef k' _) = compare k k' + +castErr :: (Typeable a1, Typeable a2) => a1 -> a2 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 previously stored one for the same key\n" - Just x -> x + r = fromMaybe + (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 previously stored one for the same key\n") + (cast a) {- | Indexable is an utility class used to derive instances of IResource @@ -63,9 +67,9 @@ @ -} class Indexable a where - key:: a -> String + key :: a -> String defPath :: a -> String -- ^ additional extension for default file paths. - -- IMPORTANT: defPath must depend on the datatype, not the value (must be constant). Default is ".tcachedata/" + -- 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 @@ -101,9 +105,9 @@ class Serializable a where serialize :: a -> B.ByteString deserialize :: B.ByteString -> a - deserialize= error "No deserialization defined for your data" + deserialize = error "No deserialization defined for your data" deserialKey :: String -> B.ByteString -> a - deserialKey _ v= deserialize v + deserialKey _ = deserialize setPersist :: a -> Maybe Persist -- ^ `defaultPersist` if Nothing setPersist = const Nothing @@ -121,26 +125,33 @@ -- | a persist mechanism has to implement these three primitives -- 'filePersist' is the default file persistence data Persist = Persist{ - readByKey :: (Key -> IO(Maybe B.ByteString)) -- ^ read by key. It must be strict - , write :: (Key -> B.ByteString -> IO()) -- ^ write. It must be strict - , delete :: (Key -> IO())} -- ^ delete + readByKey :: Key -> IO(Maybe B.ByteString) -- ^ read by key. It must be strict + , write :: Key -> B.ByteString -> IO() -- ^ write. It must be strict + , delete :: Key -> IO()} -- ^ delete -- | Implements default default-persistence of objects in files with their keys as filenames +filePersist :: Persist filePersist = Persist {readByKey= defaultReadByKey ,write = defaultWrite ,delete = defaultDelete} +defaultPersistIORef :: IORef Persist +{-# NOINLINE defaultPersistIORef #-} defaultPersistIORef = unsafePerformIO $ newIORef filePersist -- | Set the default persistence mechanism of all 'serializable' objects that have -- @setPersist= const Nothing@. By default it is 'filePersist' -- -- this statement must be the first one before any other TCache call -setDefaultPersist p= writeIORef defaultPersistIORef p +setDefaultPersist :: Persist -> IO () +setDefaultPersist = writeIORef defaultPersistIORef +{-# NOINLINE getDefaultPersist #-} +getDefaultPersist :: Persist getDefaultPersist = unsafePerformIO $ readIORef defaultPersistIORef +getPersist :: (Serializable a, Typeable a) => a -> Persist getPersist x= unsafePerformIO $ case setPersist x of Nothing -> readIORef defaultPersistIORef Just p -> return p @@ -149,85 +160,89 @@ ++ "error was:" ++ show e) -defaultReadByKey :: String-> IO (Maybe B.ByteString) +defaultReadByKey :: String-> IO (Maybe B.ByteString) defaultReadByKey k= iox -- !> "defaultReadByKey" where - iox = handle handler $ do - s <- readFileStrict k - return $ Just s -- `debug` ("read "++ filename) + iox = handle handler $ do + s <- readFileStrict k + return $ Just s -- `debug` ("read "++ filename) - - handler :: IOError -> IO (Maybe B.ByteString) - handler e - | isAlreadyInUseError e = defaultReadByKey k + + handler :: IOError -> IO (Maybe B.ByteString) + handler e + | isAlreadyInUseError e = defaultReadByKey k | isDoesNotExistError e = return Nothing - | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e) + | otherwise= if "invalid" `isInfixOf` ioeGetErrorString e then error $ "defaultReadByKey: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path:\n"++ k++"\"" - + else defaultReadByKey k defaultWrite :: String-> B.ByteString -> IO() -defaultWrite filename x= safeWrite filename x +defaultWrite = safeWrite + +safeWrite :: FilePath -> B.ByteString -> IO () 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 + 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= if ("invalid" `isInfixOf` ioeGetErrorString e) + | otherwise= if "invalid" `isInfixOf` ioeGetErrorString e then - error $ "defaultWriteResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path: "++ filename + error $ "defaultWriteResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path: "++ filename else do hPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" safeWrite filename str - + defaultDelete :: String -> IO() -defaultDelete filename =do +defaultDelete filename = handle (handler filename) $ removeFile filename - + where - - handler :: String -> IOException -> IO () - handler file e + + handler :: String -> IOException -> IO () + handler _ e | isDoesNotExistError e= return () --`debug` "isDoesNotExistError" | isAlreadyInUseError e= do hPutStrLn stderr $ "defaultDelResource: busy" ++ " in file: " ++ filename ++ " retrying" -- threadDelay 100000 --`debug`"isAlreadyInUseError" - defaultDelete filename + defaultDelete filename | otherwise = do - hPutStrLn stderr $ "defaultDelResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" + hPutStrLn stderr $ "defaultDelResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" -- threadDelay 100000 --`debug` ("otherwise " ++ show e) defaultDelete filename - + +defReadResourceByKey :: (Indexable a, Serializable a, Typeable a) => String -> IO (Maybe a) defReadResourceByKey k= iox where iox= do let Persist f _ _ = getPersist x f file >>= evaluate . fmap (deserialKey k) where file= defPath x ++ k - x= undefined `asTypeOf` (fromJust $ unsafePerformIO iox) + x= undefined `asTypeOf` fromJust (unsafePerformIO iox) +defWriteResource :: (Indexable a, Serializable a, Typeable a) => a -> IO () defWriteResource s= do let Persist _ f _ = getPersist s f (defPath s ++ key s) $ serialize s +defDelResource :: (Indexable a, Serializable a, Typeable a) => a -> IO () defDelResource s= do let Persist _ _ f = getPersist s f $ defPath s ++ key s - - --- | Strict read from file, needed for default file persistence + + +-- | Strict read from file, needed for default file persistence +readFileStrict :: FilePath -> IO B.ByteString readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h where - readIt h= do - s <- hFileSize h - let n= fromIntegral s - str <- B.hGet h n - return str - + readIt h= do + s <- hFileSize h + let n= fromIntegral s + B.hGet h n diff --git a/Data/TCache/IResource.hs b/Data/TCache/IResource.hs --- a/Data/TCache/IResource.hs +++ b/Data/TCache/IResource.hs @@ -1,38 +1,27 @@ {-# LANGUAGE ScopedTypeVariables , UndecidableInstances, FlexibleInstances #-} -module Data.TCache.IResource where +module Data.TCache.IResource where -import Data.Typeable -import System.IO.Unsafe -import Control.Concurrent.STM -import Control.Concurrent -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) - - + {- | Must be defined for every object to be cached. -} -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. +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@ - + + @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"}@ - + @ 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 - + 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 @@ -45,7 +34,7 @@ . However, because it is executed by 'safeIOToSTM' it is guaranteed that the execution is not interrupted. -} readResourceByKey :: String -> IO(Maybe a) - readResourceByKey k= return . head =<< readResourcesByKey [k] + readResourceByKey k= head <$> readResourcesByKey [k] -- | hopefully optimized read of many objects by key. readResourcesByKey :: [String] -> IO [Maybe a] readResourcesByKey = mapM readResourceByKey @@ -55,7 +44,7 @@ readResource :: a -> IO (Maybe a) readResource x = readResourceByKey $ keyResource x - -- | To write into persistent storage. It must be strict. + -- | To write into 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. -- . However, because it is executed by 'safeIOToSTM' it is guaranteed that the execution is not interrupted. -- All the new obbects are writeen to the database on synchromization, @@ -63,165 +52,30 @@ -- Commit code must be located in the postcondition. (see `setConditions`) -- Since there is no provision for rollback from failure in writing to -- persistent storage, 'writeResource' must retry until success. - writeResource:: a-> IO() - writeResource r= writeResources [r] - - -- | multiple write (hopefully) in a single request. That is up to you and your backend - -- . Defined by default as 'mapM_ writeResource' - writeResources :: [a] -> IO() - writeResources= mapM_ writeResource + writeResource:: a-> IO() + writeResource r= writeResources [r] - -- | Delete the resource. It is called syncronously. So it must commit - delResource:: a-> IO() - delResource x= delResources [x] - - delResources :: [a] -> IO() - delResources= mapM_ delResource --- | Resources data definition used by 'withSTMResources' + -- | multiple write (hopefully) in a single request. That is up to you and your backend + -- . Defined by default as 'mapM_ writeResource' + writeResources :: [a] -> IO() + writeResources= mapM_ writeResource + + -- | Delete the resource. It is called syncronously. So it must commit + delResource:: a-> IO() + delResource x= delResources [x] + + delResources :: [a] -> IO() + delResources= mapM_ delResource +-- | Resources data definition used by 'withSTMResources' data Resources a b = Retry -- ^ forces a retry - | Resources + | 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 + , 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 - - --} - - - -{- -defaultReadResource :: (Serializable a, Indexable a, Typeable a) => a -> IO (Maybe a) -defaultReadResource x= defaultReadResourceByKey $ key 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 - - -newtype Transient a= Transient a - --- | Transient wraps any indexable object for living in the cache, but not --- in persistent storage. This is useful for memoization. --- @Transient x@ is neither writeen nor read. -instance Indexable a => IResource (Transient a) where - keyResource (Transient x)= key x - readResourceByKey = const $ return Nothing - writeResource= const $ return () - delResource = const $ return () - --} +-- | Empty resources: @resources= Resources [] [] ()@ +resources :: Resources a () +resources = Resources [] [] () diff --git a/Data/TCache/IndexQuery.hs b/Data/TCache/IndexQuery.hs --- a/Data/TCache/IndexQuery.hs +++ b/Data/TCache/IndexQuery.hs @@ -69,9 +69,9 @@ -} -{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses -, FunctionalDependencies, FlexibleInstances, UndecidableInstances -, TypeSynonymInstances, IncoherentInstances, OverlappingInstances #-} +{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, + FlexibleContexts, UndecidableInstances, TypeSynonymInstances, IncoherentInstances, MonoLocalBinds #-} + module Data.TCache.IndexQuery( index , (.==.) @@ -91,12 +91,8 @@ import Data.TCache.Defs import Data.List import Data.Typeable -import Control.Concurrent.STM -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Map as M -import Data.IORef -import qualified Data.Map as M -import System.IO.Unsafe import Data.ByteString.Lazy.Char8(pack, unpack) @@ -117,8 +113,8 @@ delResource = defDelResource - -data Index reg a= Index (M.Map a [DBRef reg]) deriving ( Show, Typeable) +-- was data before hlint suggested to use a newtype here +newtype Index reg a= Index (M.Map a [DBRef reg]) deriving ( Show, Typeable) instance (IResource reg, Typeable reg, Ord a, Read a) => Read (Index reg a) where @@ -129,19 +125,20 @@ instance (Queriable reg a) => Serializable (Index reg a) where serialize= pack . show deserialize= read . unpack - setPersist index= persistIndex $ getType index + setPersist index1= persistIndex $ getType index1 where getType :: Index reg a -> reg getType= undefined -- type level +keyIndex :: (Show a1, Show a2) => a1 -> a2 -> String keyIndex treg tv= "index-" ++ show treg ++ show tv instance (Typeable reg, Typeable a) => Indexable (Index reg a) where - key map= keyIndex typeofreg typeofa + key map1= keyIndex typeofreg typeofa where - [typeofreg, typeofa]= typeRepArgs $! typeOf map + [typeofreg, typeofa]= typeRepArgs $! typeOf map1 -- defPath index= defPath $ ofRegister index -- where -- ofRegister :: Index reg a -> reg @@ -165,7 +162,11 @@ getIndexr rindex val= do mindex <- readDBRef rindex - let index = case mindex of Just (Index index) -> index; _ -> M.empty + let index = case mindex of + Just (Index index) -> index + _ -> do + let fields= show $ typeOf rindex + error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IdexQuery.index\" to start indexing this field" let dbrefs= case M.lookup val index of Just dbrefs -> dbrefs @@ -178,9 +179,9 @@ ) => (reg -> a) -> DBRef (Index reg a) -> DBRef reg -> Maybe reg -> STM () -selectorIndex selector rindex pobject mobj = do +selectorIndex selector rindex1 pobject mobj1 = do moldobj <- readDBRef pobject - choice moldobj mobj + choice moldobj mobj1 where choice moldobj mobj= case (moldobj, mobj) of @@ -194,34 +195,37 @@ (Just oldobj, Nothing) -> do -- delete the old selector value from the index let val= selector oldobj - (rindex,Index index, dbrefs) <- getIndexr rindex val + (rindex,Index index2, dbrefs) <- getIndexr rindex1 val let dbrefs'= Data.List.delete pobject dbrefs - writeDBRef rindex $ Index (M.insert val dbrefs' index) + writeDBRef rindex $ Index (M.insert val dbrefs' index2) (Nothing, Just obj) -> do -- add the new value to the index let val= selector obj - (rindex,Index index, dbrefs) <- getIndexr rindex val + (rindex,Index index2, dbrefs) <- getIndexr rindex1 val let dbrefs'= nub $ Data.List.insert pobject dbrefs - writeDBRef rindex $ Index (M.insert val dbrefs' index) + writeDBRef rindex $ Index (M.insert val dbrefs' index2) {- | Register a trigger for indexing the values of the field passed as parameter. the indexed field can be used to perform relational-like searches -} -index - :: (Queriable reg a) => - (reg -> a) -> IO () +index :: (Queriable reg a) => (reg -> a) -> IO () index sel= do let [one, two]= typeRepArgs $! typeOf sel rindex= getDBRef $! keyIndex one two addTrigger $ selectorIndex sel rindex let proto= Index M.empty `asTypeOf` indexsel sel - withResources [proto] $ init proto + withResources [proto] $ init1 proto where - init proto [Nothing] = [proto] - init _ [Just _] = [] + init1 proto [Nothing] = [proto] + init1 _ [Just _] = [] + init1 _ (Nothing:_:_) = error "this will never happen(?)" + init1 _ (Just _:_:_) = error "this will never happen(?)" + init1 _ [] = error "this will never happen(?)" + indexsel :: (reg-> a) -> Index reg a indexsel= undefined + -- | implement the relational-like operators, operating on record fields class RelationOps field1 field2 res | field1 field2 -> res where (.==.) :: field1 -> field2 -> STM res @@ -251,9 +255,9 @@ return $ mix idxs idxs' where opv (v, _ )(v', _)= v `op` v' - mix xs ys= - let zlist= [(x,y) | x <- xs , y <- ys, x `opv` y] - in map ( \(( _, xs),(_ ,ys)) ->(xs,ys)) zlist + mix xs1 ys1 = + let zlist= [(x,y) | x <- xs1 , y <- ys1, x `opv` y] + in map ( \(( _, xs2),(_ ,ys2)) ->(xs2, ys2)) zlist type JoinData reg reg'=[([DBRef reg],[DBRef reg'])] @@ -277,13 +281,11 @@ instance SetOperations [DBRef a] [DBRef a] [DBRef a] where (.&&.) fxs fys= do xs <- fxs - ys <- fys - return $ intersect xs ys + intersect xs <$> fys (.||.) fxs fys= do xs <- fxs - ys <- fys - return $ union xs ys + union xs <$> fys infixr 4 .&&. infixr 3 .||. @@ -292,12 +294,12 @@ (.&&.) fxs fys= do xss <- fxs ys <- fys - return [(intersect xs ys, zs) | (xs,zs) <- xss] + return [(xs `intersect` ys, zs) | (xs,zs) <- xss] (.||.) fxs fys= do xss <- fxs ys <- fys - return [(union xs ys, zs) | (xs,zs) <- xss] + return [(xs `union` ys, zs) | (xs,zs) <- xss] instance SetOperations [DBRef a] (JoinData a a') (JoinData a a') where (.&&.) fxs fys= fys .&&. fxs @@ -307,12 +309,12 @@ (.&&.) fxs fys= do xss <- fxs ys <- fys - return [(zs,intersect xs ys) | (zs,xs) <- xss] + return [(zs, xs `intersect` ys) | (zs,xs) <- xss] (.||.) fxs fys= do xss <- fxs ys <- fys - return [(zs, union xs ys) | (zs,xs) <- xss] + return [(zs, xs `union` ys) | (zs,xs) <- xss] -- | return all the (indexed) values which this field has and a DBRef pointer to the register @@ -322,23 +324,22 @@ let rindex= getDBRef $! keyIndex one two mindex <- readDBRef rindex case mindex of - Just (Index index) -> return $ M.toList index; + Just (Index index1) -> return $ M.toList index1; _ -> do let fields= show $ typeOf selector - error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IdexQuery.index\" to start indexing this field" + error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IndexQuery.index\" to start indexing this field" retrieve :: Queriable reg a => (reg -> a) -> a -> (a -> a -> Bool) -> STM[DBRef reg] retrieve field value op= do - index <- indexOf field - let higuer = map (\(v, vals) -> if op v value then vals else []) index + index1 <- indexOf field + let higuer = map (\(v, vals) -> if op v value then vals else []) index1 return $ concat higuer -- from a Query result, return the records, rather than the references recordsWith :: (IResource a, Typeable a) => STM [DBRef a] -> STM [ a] -recordsWith dbrefs= dbrefs >>= mapM readDBRef >>= return . catMaybes - +recordsWith dbrefs= catMaybes <$> (dbrefs >>= mapM readDBRef) class Select selector a res | selector a -> res where @@ -353,23 +354,23 @@ instance (Typeable reg, IResource reg) => Select (reg -> a) (STM [DBRef reg]) (STM [a]) where - select sel xs= return . map sel =<< return . catMaybes =<< mapM readDBRef =<< xs + select sel xs= map sel <$> (catMaybes <$> (mapM readDBRef =<< xs)) instance (Typeable reg, IResource reg, Select (reg -> a) (STM [DBRef reg]) (STM [a]), Select (reg -> b) (STM [DBRef reg]) (STM [b]) ) - => Select ((reg -> a),(reg -> b)) (STM [DBRef reg]) (STM [(a,b)]) + => Select (reg -> a, reg -> b) (STM [DBRef reg]) (STM [(a,b)]) where - select (sel, sel') xs= mapM (\x -> return (sel x, sel' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs + select (sel, sel') xs= mapM (\x -> return (sel x, sel' x)) =<< catMaybes <$> (mapM readDBRef =<< xs) instance (Typeable reg, IResource reg, Select (reg -> a) (STM [DBRef reg]) (STM [a]), Select (reg -> b) (STM [DBRef reg]) (STM [b]), Select (reg -> c) (STM [DBRef reg]) (STM [c]) ) - => Select ((reg -> a),(reg -> b),(reg -> c)) (STM [DBRef reg]) (STM [(a,b,c)]) + => Select (reg -> a, reg -> b, reg -> c) (STM [DBRef reg]) (STM [(a,b,c)]) where - select (sel, sel',sel'') xs= mapM (\x -> return (sel x, sel' x, sel'' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs + select (sel, sel',sel'') xs= mapM (\x -> return (sel x, sel' x, sel'' x)) =<< catMaybes <$> (mapM readDBRef =<< xs) instance (Typeable reg, IResource reg, @@ -377,9 +378,9 @@ Select (reg -> b) (STM [DBRef reg]) (STM [b]), Select (reg -> c) (STM [DBRef reg]) (STM [c]), Select (reg -> d) (STM [DBRef reg]) (STM [d]) ) - => Select ((reg -> a),(reg -> b),(reg -> c),(reg -> d)) (STM [DBRef reg]) (STM [(a,b,c,d)]) + => Select (reg -> a, reg -> b, reg -> c, reg -> d) (STM [DBRef reg]) (STM [(a,b,c,d)]) where - select (sel, sel',sel'',sel''') xs= mapM (\x -> return (sel x, sel' x, sel'' x, sel''' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs + select (sel, sel',sel'',sel''') xs= mapM (\x -> return (sel x, sel' x, sel'' x, sel''' x)) =<< catMaybes <$> (mapM readDBRef =<< xs) -- for join's (field1 op field2) @@ -387,11 +388,11 @@ Typeable reg', IResource reg', Select (reg -> a) (STM [DBRef reg]) (STM [a]), Select (reg' -> b) (STM [DBRef reg']) (STM [b]) ) - => Select ((reg -> a),(reg' -> b)) (STM (JoinData reg reg')) (STM [([a],[b])]) + => Select (reg -> a, reg' -> b) (STM (JoinData reg reg')) (STM [([a],[b])]) where select (sel, sel') xss = xss >>= mapM select1 where select1 (xs, ys) = do - rxs <- return . map sel =<< return . catMaybes =<< mapM readDBRef xs - rys <- return . map sel' =<< return . catMaybes =<< mapM readDBRef ys + rxs <- map sel <$> (catMaybes <$> mapM readDBRef xs) + rys <- map sel' <$> (catMaybes <$> mapM readDBRef ys) return (rxs,rys) diff --git a/Data/TCache/IndexText.hs b/Data/TCache/IndexText.hs --- a/Data/TCache/IndexText.hs +++ b/Data/TCache/IndexText.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE TypeSynonymInstances - , DeriveDataTypeable - , FlexibleInstances - , UndecidableInstances - , MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, + UndecidableInstances, MultiParamTypeClasses #-} {- | Implements full text indexation (`indexText`) and text search(`contains`), as an addition to @@ -71,23 +68,20 @@ import System.Mem.StableName import Data.List((\\)) import GHC.Conc(unsafeIOToSTM) -import Control.Concurrent(forkIO) import Data.Char -import Control.Concurrent(threadDelay) import Data.ByteString.Lazy.Char8(pack, unpack) import Control.Monad -import System.IO.Unsafe --import Debug.Trace --(!>)= flip trace -data IndexText= IndexText - { fieldType :: !String - , lastDoc :: Int - , mapDocKeyInt :: M.Map String Int - , mapIntDocKey :: M.Map Int String - , mapTextInteger :: M.Map T.Text Integer - } deriving (Typeable) +data IndexText = IndexText + !String -- fieldType + Int -- lastDoc + (M.Map String Int) -- mapDocKeyInt + (M.Map Int String) -- mapIntDocKey + (M.Map T.Text Integer) -- mapTextInteger + deriving (Typeable) instance Show IndexText where @@ -110,38 +104,57 @@ readResourceByKey = defReadResourceByKey delResource = defDelResource +{- readInitDBRef v x= do mv <- readDBRef x case mv of Nothing -> writeDBRef x v >> return v Just v -> return v +-} -add ref t key w = op ref t setBit w key -del ref t key w = op ref t clearBit w key +add :: DBRef IndexText -> String -> String -> [T.Text] -> STM () +add ref t key1 w = op ref t setBit w key1 -op refIndex t set ws key = do +del :: DBRef IndexText -> String -> String -> [T.Text] -> STM () +del ref t key1 w = op ref t clearBit w key1 + +op :: DBRef IndexText -> String -> (Integer -> Int -> Integer) -> [T.Text] -> String -> STM () +op refIndex t set ws1 key1 = do mindex <- readDBRef refIndex - let mindex'= process mindex ws + let mindex'= process mindex ws1 writeDBRef refIndex $ fromJust mindex' where process mindex []= mindex - process mindex (w:ws)= + process mindex (w:ws) = case mindex of - Nothing -> process (Just $ IndexText t 0 (M.singleton key 0) (M.singleton 0 key) (M.singleton w 1)) ws - Just (IndexText t n mapSI mapIS map) -> do - let (docLocation,n', mapSI',mapIS')= case M.lookup key mapSI of - Nothing -> let n'= n+1 in (n', n' - , M.insert key n' mapSI - , M.insert n' key mapIS) -- new Document + Nothing -> process (Just $ IndexText t 0 (M.singleton key1 0) (M.singleton 0 key1) (M.singleton w 1)) ws + Just (IndexText _ n mapSI mapIS map1) -> do + let (docLocation, n1, mapSI',mapIS')= case M.lookup key1 mapSI of + Nothing -> let n2= n+1 in (n2, n2 + , M.insert key1 n2 mapSI + , M.insert n2 key1 mapIS) -- new Document Just m -> (m,n, mapSI,mapIS) -- already indexed document - case M.lookup w map of + case M.lookup w map1 of Nothing -> --new word - process (Just $ IndexText t n' mapSI' mapIS' (M.insert w (set 0 docLocation) map)) ws + process (Just $ IndexText t n1 mapSI' mapIS' (M.insert w (set 0 docLocation) map1)) ws Just integer -> -- word already indexed - process (Just $ IndexText t n' mapSI' mapIS' $ M.insert w (set integer docLocation) map) ws + process (Just $ IndexText t n1 mapSI' mapIS' $ M.insert w (set integer docLocation) map1) ws +addProto :: Typeable a => a -> IO () +addProto sel = do + let [t1,t2]= typeRepArgs $! typeOf sel + let t = show t1 ++ show t2 + let proto = IndexText t 0 M.empty M.empty M.empty + withResources [proto] $ init' proto + where + init' proto [Nothing] = [proto] + init' _ [Just _] = [] + init' _ [] = error "this will never happen(?)" + init' _ (Nothing:_:_) = error "this will never happen(?)" + init' _ (Just _:_:_) = error "this will never happen(?)" + -- | start a trigger to index the contents of a register field indexText :: (IResource a, Typeable a, Typeable b) @@ -150,13 +163,8 @@ -> IO () indexText sel convert= do addTrigger (indext sel (words1 . convert)) - let [t1,t2]= typeRepArgs $! typeOf sel - t= show t1 ++ show t2 - let proto = IndexText t 0 M.empty M.empty M.empty - withResources [proto] $ init proto - where - init proto [Nothing] = [proto] - init _ [Just _] = [] + addProto sel + -- | trigger the indexation of list fields with elements convertible to Text indexList :: (IResource a, Typeable a, Typeable b) @@ -165,80 +173,83 @@ -> IO () indexList sel convert= do addTrigger (indext sel convert) - let [t1,t2]= typeRepArgs $! typeOf sel - t= show t1 ++ show t2 - let proto= IndexText t 0 M.empty M.empty M.empty - withResources [proto] $ init proto - - where - init proto [Nothing] = [proto] - init _ [Just _]= [] - - + addProto sel 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 +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) -> add refIndex t (keyResource reg) . convert $ sel reg - (Just oldreg, Nothing) -> 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 - if st== st' - then return () - else do - let key= keyResource reg - let wrds = convert $ sel oldreg - let wrds'= convert $ sel reg - let new= wrds' \\ wrds - let old= wrds \\ wrds' - when(not $ null old) $ del refIndex t key old - when(not $ null new) $ add refIndex t key new - return() - where - [t1,t2]= typeRepArgs $! typeOf sel - t= show t1 ++ show t2 - refIndex= getDBRef . key $ IndexText t u u u u where u= undefined + {-f = void $ forkIO (atomically f1)-} + f1 = do + moldreg <- readDBRef dbref + case (moldreg, mreg) of + (Nothing, Just reg) -> add refIndex t (keyResource reg) . convert $ sel reg + (Just oldreg, Nothing) -> 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 + if st == st' + then return () + else do + let key1 = keyResource reg + let wrds = convert $ sel oldreg + let wrds' = convert $ sel reg + let new = wrds' \\ wrds + let old = wrds \\ wrds' + unless (null old) $ del refIndex t key1 old + unless (null new) $ add refIndex t key1 new + (Nothing, Nothing) -> error "this will never happen(?)" + where + [t1, t2] = typeRepArgs $! typeOf sel + t = show t1 ++ show t2 + refIndex = getDBRef . key $ IndexText t u u u u + where + u = undefined +-- avoid duplicate code +targs :: Typeable a => a -> STM (Maybe IndexText) +targs sel = do + let [t1, t2]= typeRepArgs $! typeOf sel + let t= show t1 ++ show t2 + let u= undefined + withSTMResources [IndexText t u u u u] + $ \[r] -> resources{toReturn= r} + -- | return the DBRefs of the registers whose field (first parameter, usually a container) contains the requested value. 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 - mr <- withSTMResources [IndexText t u u u u] - $ \[r] -> resources{toReturn= r} - case mr of - Nothing -> do - let fields= show $ typeOf sel - error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IdexQuery.index\" to start indexing this field" - Just (IndexText t n _ mmapIntString map1) -> - case M.lookup w map1 of - Nothing -> return [] - Just integer -> do - let mns=map (\n ->case testBit integer n of True -> Just n; _ -> Nothing) [0..n] - let wordsr = catMaybes $ map (\n -> M.lookup n mmapIntString) $ catMaybes mns - return $ map getDBRef wordsr +containsElem sel wstr = do + let w = T.pack wstr + mr <- targs sel + case mr of + Nothing -> do + let fields = show $ typeOf sel + error $ + "the index for " ++ + fields ++ " do not exist. At main, use \"Data.TCache.IndexQuery.index\" to start indexing this field" + Just (IndexText _ n _ mmapIntString map1) -> + case M.lookup w map1 of + Nothing -> return [] + Just integer -> do + let mns = + map + (\i -> + if testBit integer i + then Just i + else Nothing) + [0 .. n] + let wordsr = mapMaybe (`M.lookup` mmapIntString) $ catMaybes mns + return $ map getDBRef wordsr -- | return all the values of a given field (if it has been indexed with 'index') allElemsOf :: (IResource a, Typeable a, Typeable b) => (a -> b) -> STM [T.Text] allElemsOf sel = do - let [t1, t2]= typeRepArgs $! typeOf sel - let t= show t1 ++ show t2 - let u= undefined - mr <- withSTMResources [IndexText t u u u u] - $ \[r] -> resources{toReturn= r} + mr <- targs sel case mr of Nothing -> return [] - Just (IndexText t n _ _ map) -> return $ M.keys map + Just (IndexText _ _ _ _ map') -> return $ M.keys map' -words1= filter filterWordt {-( (<) 2 . T.length)-} . T.split (\c -> isSeparator c || c=='\n' || isPunctuation c ) +words1 :: T.Text -> [T.Text] +words1 = filter filterWordt {-( (<) 2 . T.length)-} . T.split (\c -> isSeparator c || c=='\n' || isPunctuation c ) -- | return the DBRefs whose fields include all the words in the requested text contents.Except the -- words with less than three characters that are not digits or uppercase, that are filtered out before making the query @@ -252,7 +263,10 @@ [w] -> containsElem sel w ws -> do let rs = map (containsElem sel) $ filter filterWord ws - foldl (.&&.) (head rs) (tail rs) + foldl1 (.&&.) rs -filterWordt w= T.length w >2 || or (map (\c -> isUpper c || isDigit c) (T.unpack w)) -filterWord w= length w >2 || or (map (\c -> isUpper c || isDigit c) w) +filterWordt :: T.Text -> Bool +filterWordt w = T.length w >2 || any (\c -> isUpper c || isDigit c) (T.unpack w) + +filterWord :: Foldable t => t Char -> Bool +filterWord w = length w >2 || any (\c -> isUpper c || isDigit c) w diff --git a/Data/TCache/Memoization.hs b/Data/TCache/Memoization.hs --- a/Data/TCache/Memoization.hs +++ b/Data/TCache/Memoization.hs @@ -1,151 +1,155 @@ ------------------------------------------------------------------------------ --- --- Module : Memoization --- Copyright : Alberto GOmez Corona --- License : BSD3 --- --- Maintainer : agocorona@gmail.com --- Stability : Experimental --- Portability : Non portable (uses stablenames) --- --- | --- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable - , ExistentialQuantification - , FlexibleInstances - , TypeSynonymInstances #-} -module Data.TCache.Memoization (writeCached,cachedByKey,cachedByKeySTM,flushCached,cachedp,addrStr,Executable(..)) - -where -import Data.Typeable -import Data.TCache -import Data.TCache.Defs(Indexable(..)) -import System.Mem.StableName -import System.IO.Unsafe -import System.Time -import Data.Maybe(fromJust) -import Control.Monad.Trans -import Control.Monad.Identity -import Data.RefSerialize(addrHash,newContext) ---import Debug.Trace ---(!>)= flip trace - -data Cached a b= forall m.Executable m => Cached a (a -> m b) b Integer deriving Typeable - -context= unsafePerformIO newContext - --- | given a string, return a key that can be used in Indexable instances --- Of non persistent objects, such are cached objects (it changes fron execution to execution) --- . It uses `addrHash` -addrStr x= "addr" ++ show hash - where - hash = case unsafePerformIO $ addrHash context x of - Right x -> x - Left x -> x - --- | to execute a monad for the purpose of memoizing its result -class Executable m where - execute:: m a -> a - -instance Executable IO where - execute m = unsafePerformIO $! f1 m "" - where - f1 m x= m - -instance Executable Identity where - execute (Identity x)= x - -instance MonadIO Identity where - liftIO f= Identity $! unsafePerformIO $! f - - -cachedKeyPrefix = "cached" - -instance (Indexable a) => IResource (Cached a b) where - keyResource ch@(Cached a _ _ _)= cachedKeyPrefix ++ key a -- ++ unsafePerformIO (addrStr f ) - - writeResource _= return () - delResource _= return () - readResourceByKey k= return Nothing -- error $ "access By key is undefined for cached objects.key= " ++ k - - - readResource (Cached a f _ _)=do - TOD tnow _ <- getClockTime - let b = execute $ f a - return . Just $ Cached a f b tnow -- !> "readRe" - ---cache time f a= do --- TOD tnow _ <- getClockTime --- let b = execute $ f a --- withResources [] . const $ [Cached a f b tnow] -- !> "writeRe"] --- ---cacheKey key time f= cache time (const f) key - --- | memoize the result of a computation for a certain time. This is useful for caching costly data --- such web pages composed on the fly. --- --- time == 0 means infinite - ---getCachedRef :: (Indexable a,Typeable a, Typeable b) => a -> DBRef (Cached a b) ---getCachedRef x = getDBRef $ keyResource (Cached x (u u u) where u= undefined - -writeCached - :: (Typeable b, Typeable a, Indexable a, Executable m) => - a -> (a -> m b) -> b -> Integer -> STM () -writeCached a b c d= - withSTMResources [] . const $ resources{toAdd= [Cached a b c d] } - - -cached :: (Indexable a,Typeable a, Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a -> m b -cached time f a= liftIO . atomically $ cachedSTM time f a - -cachedSTM time f a= do - let prot= Cached a f undefined undefined - let ref= getDBRef $ keyResource prot - cho@(Cached _ _ b t) <- readDBRef ref `onNothing` fillIt ref prot - case time of - 0 -> return b - _ -> do - TOD tnow _ <- unsafeIOToSTM $ getClockTime - if tnow - t >= fromIntegral time - then do - Cached _ _ b _ <- fillIt ref prot - return b - else return b - where - -- has been invalidated by flushCached - fillIt ref proto= do - let r = unsafePerformIO $return . fromJust =<< readResource proto -- !> "fillIt" - writeDBRef ref r - return r - --- | Memoize the result of a computation for a certain time. A string 'key' is used to index the result --- --- The Int parameter is the timeout, in second after the last evaluation, after which the cached value will be discarded and the expression will be evaluated again if demanded --- . Time == 0 means no timeout -cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int -> m a -> m a -cachedByKey key time f = cached time (\_ -> f) key - -cachedByKeySTM :: (Typeable a, Executable m) => String -> Int -> m a -> STM a -cachedByKeySTM key time f = cachedSTM time (\_ -> f) key - --- Flush the cached object indexed by the key -flushCached :: String -> IO () -flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k -- !> "flushCached" - --- | a pure version of cached -cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b -cachedp f k = execute $ cached 0 (\x -> Identity $ f x) k - ---testmemo= do --- let f x = "hi"++x !> "exec1" --- let f1 x= "h0"++x !> "exec2" --- let beacon=1 --- let beacon2=2 --- print $ cachedp f (addrStr "sfs") --- print $ cachedp f (addrStr "sds") --- print $ cachedp f1 (addrStr "ssdfddd") --- print $ cachedp f1 (addrStr "sss") - - +----------------------------------------------------------------------------- +-- +-- Module : Memoization +-- Copyright : Alberto GOmez Corona +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : Experimental +-- Portability : Non portable (uses stablenames) +-- +-- | +-- +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-signatures #-} +{-# LANGUAGE DeriveDataTypeable + , ExistentialQuantification + , FlexibleInstances + , TypeSynonymInstances #-} +module Data.TCache.Memoization (writeCached,cachedByKey,cachedByKeySTM,flushCached,cachedp,addrStr,Executable(..)) + +where +import Data.Typeable +import Data.TCache +import Data.TCache.Defs(Indexable(..)) +import System.IO.Unsafe +import System.Time +import Data.Maybe(fromJust) +import Control.Monad.Trans +import Control.Monad.Identity +import Data.RefSerialize(addrHash,newContext) +--import Debug.Trace +--(!>)= flip trace + +data Cached a b= forall m.Executable m => Cached a (a -> m b) b Integer deriving Typeable + +{-# NOINLINE context #-} +context = unsafePerformIO newContext + +-- | given a string, return a key that can be used in Indexable instances +-- Of non persistent objects, such are cached objects (it changes fron execution to execution) +-- . It uses `addrHash` +addrStr :: a -> String +addrStr x= "addr" ++ show hash + where + hash = case unsafePerformIO $ addrHash context x of + Right x1 -> x1 + Left x1 -> x1 + +-- | to execute a monad for the purpose of memoizing its result +class Executable m where + execute:: m a -> a + +instance Executable IO where + execute m = unsafePerformIO $! f1 m "" + where + f1 m1 _= m1 + +instance Executable Identity where + execute (Identity x)= x + +instance MonadIO Identity where + liftIO f= Identity $! unsafePerformIO $! f + + +cachedKeyPrefix :: String +cachedKeyPrefix = "cached" + +instance (Indexable a) => IResource (Cached a b) where + keyResource (Cached a _ _ _)= cachedKeyPrefix ++ key a -- ++ unsafePerformIO (addrStr f ) + + writeResource _= return () + delResource _= return () + readResourceByKey _= return Nothing -- error $ "access By key is undefined for cached objects.key= " ++ k + + + readResource (Cached a f _ _)=do + TOD tnow _ <- getClockTime + let b = execute $ f a + return . Just $ Cached a f b tnow -- !> "readRe" + +--cache time f a= do +-- TOD tnow _ <- getClockTime +-- let b = execute $ f a +-- withResources [] . const $ [Cached a f b tnow] -- !> "writeRe"] +-- +--cacheKey key time f= cache time (const f) key + +-- | memoize the result of a computation for a certain time. This is useful for caching costly data +-- such web pages composed on the fly. +-- +-- time == 0 means infinite + +--getCachedRef :: (Indexable a,Typeable a, Typeable b) => a -> DBRef (Cached a b) +--getCachedRef x = getDBRef $ keyResource (Cached x (u u u) where u= undefined + +writeCached + :: (Typeable b, Typeable a, Indexable a, Executable m) => + a -> (a -> m b) -> b -> Integer -> STM () +writeCached a b c d= + withSTMResources [] . const $ resources{toAdd= [Cached a b c d] } + + +cached :: (Indexable a,Typeable a, Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a -> m b +cached time f a= liftIO . atomically $ cachedSTM time f a + +cachedSTM :: (Typeable a, Typeable b, Executable m, Indexable a, Integral p) => p -> (a -> m b) -> a -> STM b +cachedSTM time f a= do + let prot= Cached a f undefined undefined + let ref= getDBRef $ keyResource prot + (Cached _ _ b t) <- readDBRef ref `onNothing` fillIt ref prot + case time of + 0 -> return b + _ -> do + TOD tnow _ <- unsafeIOToSTM getClockTime + if tnow - t >= fromIntegral time + then do + Cached _ _ b1 _ <- fillIt ref prot + return b1 + else return b + where + -- has been invalidated by flushCached + fillIt ref proto= do + let r = unsafePerformIO $return . fromJust =<< readResource proto -- !> "fillIt" + writeDBRef ref r + return r + +-- | Memoize the result of a computation for a certain time. A string 'key' is used to index the result +-- +-- The Int parameter is the timeout, in second after the last evaluation, after which the cached value will be discarded and the expression will be evaluated again if demanded +-- . Time == 0 means no timeout +cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int -> m a -> m a +cachedByKey key1 time f = cached time (const f) key1 + +cachedByKeySTM :: (Typeable a, Executable m) => String -> Int -> m a -> STM a +cachedByKeySTM key1 time f = cachedSTM time (const f) key1 + +-- Flush the cached object indexed by the key +flushCached :: String -> IO () +flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k -- !> "flushCached" + +-- | a pure version of cached +cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b +cachedp f k = execute $ cached 0 (Identity . f) k + +--testmemo= do +-- let f x = "hi"++x !> "exec1" +-- let f1 x= "h0"++x !> "exec2" +-- let beacon=1 +-- let beacon2=2 +-- print $ cachedp f (addrStr "sfs") +-- print $ cachedp f (addrStr "sds") +-- print $ cachedp f1 (addrStr "ssdfddd") +-- print $ cachedp f1 (addrStr "sss") + + diff --git a/Data/TCache/Triggers.hs b/Data/TCache/Triggers.hs --- a/Data/TCache/Triggers.hs +++ b/Data/TCache/Triggers.hs @@ -1,6 +1,5 @@ - +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, BangPatterns #-} module Data.TCache.Triggers(DBRef(..),Elem(..),Status(..),addTrigger,applyTriggers) where import Data.TCache.IResource import Data.TCache.Defs @@ -9,21 +8,20 @@ import System.IO.Unsafe import Unsafe.Coerce import GHC.Conc (STM, unsafeIOToSTM) -import Data.Maybe(maybeToList,catMaybes) +import Data.Maybe(fromMaybe, fromJust) import Data.List(nubBy) -import Control.Concurrent.STM -import Debug.Trace -import Data.Maybe(fromJust) +--import Debug.Trace 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()) +data CMTrigger= forall a.(IResource a, Typeable a) => CMTrigger !(DBRef a -> Maybe a -> STM()) cmtriggers :: IORef [(TypeRep ,[CMTrigger])] -cmtriggers= unsafePerformIO $ newIORef [] +{-# NOINLINE cmtriggers #-} +cmtriggers = unsafePerformIO $ newIORef [] @@ -35,37 +33,38 @@ If 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 +addTrigger :: (IResource a, Typeable a) => (DBRef a -> Maybe a -> STM()) -> IO() +addTrigger tr = do + map' <- readIORef cmtriggers writeIORef cmtriggers $ - let ts = mbToList $ lookup atype map - in nubByType $ (atype ,CMTrigger t : ts) : map + let ts = mbToList $ lookup atype map' + in nubByType $ (atype ,CMTrigger tr : ts) : map' where nubByType= nubBy (\(t,_)(t',_) -> t==t') - (_,(atype:_))= splitTyConApp . typeOf $ TriggerType t + (_,atype:_)= splitTyConApp . typeOf $ TriggerType tr -mbToList mxs= case mxs of Nothing -> []; Just xs -> xs +mbToList :: Maybe [a] -> [a] +mbToList = fromMaybe [] -- | internally called when a DBRef is modified/deleted/created 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 + 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 + f1 (CMTrigger t)= unsafeCoerce t -mapM2_ _ [] _= return() +mapM2_ :: Monad m => (t1 -> t2 -> m a) -> [t1] -> [t2] -> m () +mapM2_ _ [] _ = return() +mapM2_ _ _ [] = return() mapM2_ f (x:xs) (y:ys)= f x y >> mapM2_ f xs ys - - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +# TCache + +TCache is a transactional cache written in Haskell with configurable persistence. It allows conventional STM transactions for objects that synchronize with a user-defined storage. State is kept synchronized between memory and permanent storage via transactions. Default persistence is via files, and is provided for testing purposes. + +0.9.0.4 : Solves a bug in the management of weak pointers that evaporated registers from the cache +0.9.0.3 : Solves a lost registers bug. +0.9.0.1 : Solves a bug when object keys generate invalid filenames, and includes changes in defaultPersistence to further separate serialization from input-output. + +0.9: Introduces full text search. Also adjusts serialization so it is achieved through byteStrings. + +This version supports backward compatibility and also permits transparent retrieval of and transactions between objects without directly using STM references. It now provides explicit STM persistent references (`DBRef`s) that leverage clean, traditional haskell reference syntax for performing database transactions. + +`DBRef`s are essentially persistent `TVar`s indexed in the cache using a traditional `readDBRef`/`writeDBRef` Haskell interface like that of the STM Monad. Additionally, because `DBRef`s are serializable, they can be embedded in serializable registers. As they are references this means they point to other serializable registers. This enables persistent, mutable and efficient inter-object relations. + +Triggers are also included in this release. These are user defined hooks that get called on register updates. They can be used for making the actualization of inter-object relations easier, and also permit higher-level customizable accesses. The query language internally uses triggers for its indexing. + +This version also implements a straight-forward, non-intrusive, type-safe pure Haskell query language that is based on register field relations. This module can be imported separately. See `Data.TCache.IndexQuery` for further information. + +The file persistence implementation is more reliable as `IO` reads are now in STM transactions. + +To ease the implementation of other user-defined persistence, `Data.TCache.DefaultPersistence` needs to be imported explicitly for deriving file persistence instances. + +The 0.9 version adds full-text indexing and search, which is incorporated into the experimental query language. + +It also changes the default Persistence mechanism. Now `ByteString`s are used for serialization and deserialization. A `Serializable` class and a `Persist` structure decouples serialization from `ByteString` and read/write to files. Both can be redefined separately, so the default persistence could be changed with `setPersist` to write to blobs in a databases, for example. Default persistence now no longer has to be in files. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,5 +1,5 @@ -#! /usr/bin/runghc - -> import Distribution.Simple -> -> main = defaultMain +#! /usr/bin/runghc + +> import Distribution.Simple +> +> main = defaultMain diff --git a/TCache.cabal b/TCache.cabal --- a/TCache.cabal +++ b/TCache.cabal @@ -1,85 +1,86 @@ -name: TCache -version: 0.12.1 -cabal-version: >= 1.6 -build-type: Simple -license: BSD3 -license-file: LICENSE -maintainer: agocorona@gmail.com -synopsis: A Transactional cache with user-defined persistence -description: TCache is a transactional cache with configurable persitence. It allows conventional - STM transactions for objects that syncronize with their user-defined storages. - State in memory and into permanent storage is transactionally coherent. - . - It has interface defined for Amazon WS and Yesod Persistent backends defined in tcache- - packages. - Persistent is a multi-backend interface for SQL and non SQL databases such in Mongo-db - . - The package implements serializable STM references, access by key and by record field value, triggers, - full text and field indexation, default serialization and a query language based on record fields - . - Since the STM references can be included in data structures and serialized, this is right - for graph databases and other NoSQL databases. - . - 0.12.0 space in index data in indexQuery.hs and IndexText.hs triggered errors in the AWS backend. - The space has been changed by '-'. So rename the "index *" files in the TCache folder - in order to be recognized. - . - 0.11.0.0 added setIndexParsist to define persistence for indexes by type. started the addition of readDBRefs, readResources and so on for simultaneous read, writes and deletes of - objects of the same type. - . - 0.10.2.0 Added setDefaultPersist and modified the signature of setPersist in Data.TCache.DefaultPersistence. - Fixed issues with ghc 7.6.3 - . - 0.10 version add memoization and a persistent and transactional collection/queue. - . - 0.10.0.8 subversion add cachedByKeySTM - . - 0.10.0.9 fixed an error in clearSyncChacheProc and SynWrite Asyncronous that checked the cache continuously - . - See "Data.TCache" for details - . - In this release: - . - Dropped Data.Hashtable (deprecated). Now it uses the package hashtables - - -category: Data, Database -author: Alberto Gómez Corona -tested-with: GHC ==7.0.3 -data-dir: "" -extra-source-files: demos/DBRef.hs - demos/IndexQuery.hs - demos/IndexText.hs - demos/basicSample.hs - demos/caching.hs - demos/triggerRelational.lhs - demos/memoization.hs - demos/DBRef.hs - -source-repository head - type: git - location: https://github.com/agocorona/TCache - -library - build-depends: base >=4 && <5, bytestring -any, - containers >=0.1.0.1, directory >=1.0, old-time >=1.0, - stm -any, text -any, mtl -any, hashtables, - RefSerialize >= 0.4.0 - - - - exposed-modules: Data.TCache Data.TCache.DefaultPersistence, - Data.TCache.Defs Data.TCache.IResource Data.TCache.IndexQuery - Data.TCache.IndexText Data.TCache.Memoization Data.TCache.Triggers - Data.Persistent.Collection - Data.Persistent.IDynamic - - - - exposed: True - buildable: True - extensions: OverlappingInstances UndecidableInstances - ScopedTypeVariables DeriveDataTypeable - hs-source-dirs: . - other-modules: - +name: TCache +version: 0.13.3 +cabal-version: >= 1.10 +synopsis: A Transactional cache with user-defined persistence +description: Please see the README on GitHub at +category: Data, Database +homepage: https://github.com/agocorona/TCache#readme +bug-reports: https://github.com/agocorona/TCache/issues +author: Alberto Gómez Corona +maintainer: agocorona@gmail.com +copyright: 2019 Alberto Gómez Corona +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + ChangeLog.md + README.md + demos/basicSample.hs + demos/caching.hs + demos/DBRef.hs + demos/DynamicSample.hs + demos/indexQuery.hs + demos/indexText.hs + demos/memoization.hs + demos/pr.hs + demos/pushpop.hs + demos/testnewdbref.hs + demos/triggerRelational.lhs + demos/weakTest.hs + Data/Persistent/IDynamic.hs + +source-repository head + type: git + location: https://github.com/agocorona/TCache + +library + exposed-modules: + Data.TCache + Data.TCache.DefaultPersistence + Data.TCache.Defs + Data.TCache.IResource + Data.TCache.IndexQuery + Data.TCache.IndexText + Data.TCache.Memoization + Data.TCache.Triggers + Data.Persistent.Collection + Data.Persistent.IDynamic + other-modules: + Paths_TCache + hs-source-dirs: + ./ + ghc-options: -Wall -Wcompat -Widentities + build-depends: + RefSerialize + , base >=4.7 && <5 + , bytestring + , containers >=0.1.0.1 + , directory >=1.0 + , hashtables + , mtl + , old-time >=1.0 + , stm + , text + default-language: Haskell2010 + +test-suite caching + type: exitcode-stdio-1.0 + main-is: caching.hs + other-modules: + Paths_TCache + hs-source-dirs: + demos + ghc-options: -Wall -Wcompat -Widentities -threaded -rtsopts -with-rtsopts=-N + build-depends: + RefSerialize + , TCache + , base >=4.7 && <5 + , bytestring + , containers >=0.1.0.1 + , directory >=1.0 + , hashtables + , mtl + , old-time >=1.0 + , stm + , text + default-language: Haskell2010 diff --git a/demos/DBRef.hs b/demos/DBRef.hs --- a/demos/DBRef.hs +++ b/demos/DBRef.hs @@ -1,41 +1,55 @@ -{-# OPTIONS -XDeriveDataTypeable -XFlexibleInstances -XUndecidableInstances #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-} module Main where import Data.TCache import Data.TCache.DefaultPersistence import Data.ByteString.Lazy.Char8(pack,unpack) -import GHC.Conc import System.IO.Unsafe import Data.Typeable -import Debug.Trace +{- +-- would create orphan instances +instance (Read a, Show a) => Serializable a where + serialize = pack . show + deserialize = read . unpack +-} +-- An Employee +data Emp = Emp + { ename :: String + , salary :: Float + } deriving (Read, Show, Typeable) +instance Serializable Emp where + serialize = pack . show + deserialize = read . unpack -newtype Other= Other String deriving (Read, Show) +instance Indexable Emp where + key Emp { ename = name } = name -data Company = Company { - cname :: String - ,personnel :: [DBRef Emp] - ,other :: Other} - deriving (Read, Show,Typeable) +-- For illustration +newtype Other = Other String deriving (Read, Show) +-- A Company +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 Serializable Company where + serialize = pack . show + deserialize = read . unpack 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 - + key Company{ cname = name } = name -myCompanyName= "mycompany" +myCompanyName :: String +myCompanyName = "mycompany" -myCompanyRef= unsafePerformIO . atomically $ do +-- Creating a Company from scratch +{-# NOINLINE myCompanyRef #-} +myCompanyRef :: DBRef Company +myCompanyRef = unsafePerformIO . atomically $ do refEmp1 <- newDBRef Emp{ename= "Emp1", salary= 34000} refEmp2 <- newDBRef Emp{ename= "Emp2", salary= 35000} @@ -48,36 +62,45 @@ ,personnel= [refEmp1, refEmp2, refEmp3, refEmp4] ,other= Other "blah blah blah"} - -- myCompany= Company myCompanyName [getDBRef "Emp1",getDBRef "Emp2",getDBRef "Emp3"] - +increaseSalaries :: Float -> STM () +increaseSalaries percent1 = do + mycompany' <- readDBRef myCompanyRef + mycompany <- case mycompany' of + Just x -> pure x + Nothing -> error "Boom" -increaseSalaries percent= do - Just mycompany <- readDBRef myCompanyRef - mapM_ (increase percent ) $ personnel mycompany + mapM_ (increase percent1 ) $ personnel mycompany where increase percent ref= do - Just emp <- readDBRef ref + emp' <- readDBRef ref + emp <- case emp' of + Just x -> pure x + Nothing -> error "Boom" + writeDBRef ref $ emp{salary= salary emp * factor} where factor= 1+ percent/ 100 -printSalaries ref= do - Just comp <- atomically $ readDBRef ref +printSalaries :: DBRef Company -> IO () +printSalaries ref1 = do + Just comp <- atomically $ readDBRef ref1 mapM_ printSalary $ personnel comp where printSalary ref= atomically (readDBRef ref) >>= print +putMsg :: String -> IO () 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" +main :: IO () +main = do + putMsg "DBRefs are cached indexable, 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 + 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" @@ -96,7 +119,7 @@ putMsg "after the increase" printSalaries myCompanyRef2 - let emp3ref= getDBRef "Emp3" + let emp3ref = getDBRef "Emp3" putMsg "tch tch, this bad boy does not deserve his salary" Just emp3 <- atomically $ readDBRef emp3ref print emp3 @@ -108,16 +131,13 @@ 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 + let emp1 = Emp{ename="Emp1", salary= -1} + let key1 = keyResource emp1 + let remp1 = getDBRef key1 + Just emp1' <- atomically $ readDBRef remp1 atomically $ flushDBRef remp1 - let remp1'= getDBRef key - atomically $ writeDBRef remp1' $ emp1{salary=0} + let remp1' = getDBRef key1 + 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,73 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module Main where +import Data.TCache +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8(pack,unpack) +import Data.Typeable + +{------------- tests--------- +example of IDynamic usage. + +-} + +-- Very simple data: +-- Two objects with two different datatypes: MyInt and MyString +-- We use newtypes so we don't need to create orphan instances + +newtype MyInt = MyInt { fromMyInt :: Int } deriving ( Eq, Show, Typeable, Read ) +newtype MyString = MyString { fromMyString :: String } deriving ( Eq, Show, Typeable, Read ) + +instance Indexable MyString where + -- making the key 2 chars wide + key x = take 2 $ fromMyString x + +instance Indexable MyInt where + -- just use the string representation as key here + key = show + +instance Serializable MyString where + serialize = pack . show + deserialize = read . unpack + +instance Serializable MyInt where + serialize = pack . show + deserialize = read . unpack + + +main :: IO () +main= do + putStrLn "see the code to know the meaning of he results" + + -- NOTE: registerType no longer needed + + + let x = MyInt 1 + + -- now *Resources primitives support different datatypes + -- without the need of Data.Dynamic + withResources [] $ const [x] + withResources [] $ const [MyString "hola"] --resources creation + + syncCache + + res1 <- getResource x + print res1 + + res2 <- getResource $ MyString "ho" + print res2 + + -- to use heterogeneous data in the same transaction, + -- use DBRef's: + s <- atomically $ do + let refInt = getDBRef $ key x :: DBRef MyInt + refString = getDBRef $ key (MyString "ho") :: DBRef MyString + i <- readDBRef refInt + writeDBRef refString $ MyString $ "hola, the retrieved value of x is " ++ show i + readDBRef refString + + 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 deleted file mode 100644 --- a/demos/IndexQuery.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-} -module Main where -import Data.TCache -import Data.TCache.IndexQuery -import Data.TCache.DefaultPersistence -import Data.ByteString.Lazy.Char8(pack,unpack) -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 - -instance (Read a, Show a) => Serializable a where - serialize= pack . show - deserialize= read . unpack - -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/IndexText.hs b/demos/IndexText.hs deleted file mode 100644 --- a/demos/IndexText.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable#-} -module Main where -import Data.TCache -import Data.TCache.DefaultPersistence -import Data.TCache.IndexQuery(select) -import Data.TCache.IndexText -import Data.ByteString.Lazy.Char8(pack,unpack) -import qualified Data.Text.Lazy as T(pack) -import Data.Typeable - -data Doc= Doc{title, body :: String} deriving (Read,Show, Typeable) -instance Indexable Doc where - key Doc{title=t}= t - -instance Serializable Doc where - serialize= pack . show - deserialize= read . unpack - -main= do - indexText body T.pack - let doc= Doc{title= "title", body= "hola que tal estamos"} - rdoc <- atomically $ newDBRef doc - r1 <- atomically $ select title $ body `contains` "hola que tal" - print r1 - - atomically $ writeDBRef rdoc doc{ body= "que tal"} - r <- atomically $ select title $ body `contains` "hola que tal" - print r - if r1 == [title doc] then print "OK" else print "FAIL" - if r== [] then print "OK" else print "FAIL" diff --git a/demos/basicSample.hs b/demos/basicSample.hs --- a/demos/basicSample.hs +++ b/demos/basicSample.hs @@ -6,9 +6,11 @@ import Data.TCache.DefaultPersistence import Data.ByteString.Lazy.Char8(pack,unpack) import Control.Concurrent +import Data.Foldable (for_) import Data.Typeable import Debug.Trace +debug :: a -> String -> a debug a b= trace b a -- The data elements to be used in the example: A user will repeatedly buy Items. @@ -19,7 +21,14 @@ deriving (Read, Show, Typeable) --- The mappings between the cache and the phisical storage are defined by the interface IResource +-- defining prototypes to make missing-fields warning useful again +user_ :: Data +user_ = User{uname = undefined, uid = undefined, spent = undefined } + +item_ :: Data +item_ = Item{iname = undefined, iid = undefined, price = undefined, stock = undefined } + +-- The mappings between the cache and the physical storage are defined by the interface IResource -- to extract the unique key, -- to serializa to string -- to deserialize from string @@ -31,65 +40,66 @@ instance Indexable Data where - key User{uid=id}= id - key Item{iid=id}= id + key User { uid=id' } = id' + key Item { iid=id' } = id' instance Serializable Data where - serialize= pack . show - deserialize= read . unpack + 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, ---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. +-- 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 + +buy :: Data -> Data -> IO () +user `buy` item = withResources [user, item] buyIt where - buyIt[Just us,Just it] - | stock it > 0= [us',it'] `debug` "john buy a PC" + buyIt[Just us, Just it] + | stock it > 0 = [us',it'] `debug` ("john spent " ++ show (spent us) ++ + " so far. Hey tries to buy a PC from the stock of " ++ show (stock it)) | otherwise = error "stock is empty for this product" where - us'= us{spent=spent us + price it} - it'= it{stock= stock it-1} + 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"} +main :: IO () +main = do + -- create resources (access no resources and return two new Data objects defined in items) + withResources [] prepareItems - --wait 1 seconds - threadDelay 1000000 + -- 11 PCs are charged to the John´s account in parallel, to show transactionality + -- because there are only 10 PCs in stock, the last thread must return an error + for_ [(1::Int)..11] $ const $ forkIO $ user_{ uid = "U12345" } `buy` item_{ iid = "I54321" } - [us,it] <- getResources [User{uid="U12345"}, Item{iid="I54321"}] + -- wait a second (to let the forked io finish) + threadDelay 1000000 - putStrLn $ "user data=" ++ show us - putStrLn $ "item data=" ++ show it + -- get the contents of the resources by their keys + [us,it] <- getResources [user_{ uid = "U12345" }, item_{ iid = "I54321" }] - -- 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 + putStrLn $ "user data=" ++ show us + putStrLn $ "item data=" ++ show it - syncCache - threadDelay 1000000 + -- write the cache content in a persistent store (invoke writeResource for each resource) + -- in a real application clearSyncCacheProc can be used instead to adjust size and write the cache periodically + syncCache + threadDelay 1000000 - -- the files have been created. the files U12345 and I54321 must contain the result of the 11 iterations + -- the files U12345 and I54321 in .tcachedata must now 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 + prepareItems = const + [ User "John" "U12345" 0 + , Item "PC" "I54321" 6000 10 + ] diff --git a/demos/caching.hs b/demos/caching.hs --- a/demos/caching.hs +++ b/demos/caching.hs @@ -11,6 +11,8 @@ import Control.Concurrent import Debug.Trace import Data.Typeable + +debug :: a -> String -> a debug a b= trace b a -- The data elements to be used in the example @@ -21,39 +23,90 @@ instance Indexable Data where key (Data i _)= show i - defPath _ = "cacheData/" -- directory where the data is stored. + defPath _ = ".tcachedata/caching/" -- directory where the data is stored. instance Serializable Data where serialize= pack . show deserialize= read . unpack -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" +printStat :: (Show a1, Show a2, Show a3) => (a1, a2, a3) -> IO () +printStat (total, dirty, loaded) = + putStrLn $ "total: " ++ show total ++ " dirty: " ++ show dirty ++ " loaded: " ++ show loaded - 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" +main :: IO () +main = do + putStrLn "See the source code of this example!" + putStrLn "" + putStrLn "This program tests the caching, cleaning, re-retrieval and updating of the cache." + putStrLn "It uses the DefaultPersistence (disk) and defaultCheck (cleaning rules)." + putStrLn "It writes asyncronously every 10 seconds all changed elemements to disk." + putStrLn "When there is more than the allowed number of elements (100) in the cache it cleans them by the given rule." + putStrLn "With defaultCheck it drops elements which where not accesed since half the time between now and the last sync." putStrLn "" - putStrLn "create resources" - putStrLn " (acces no resources and return two new Data objects defined in items)" + putStrLn "Creating 200 resources with content: n 0" withResources[] $ const[Data i 0 | i <- [1..200]] + -- get stats about them (total, dirty, loaded) + statElems >>= printStat + x1 <- getResources [Data i 0 | i <- [1..200]] + putStrLn $ "Last element: " ++ show (last x1) + putStrLn "" - 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 $ "Starting the async proc with folder: " ++ defPath ( undefined :: Data) + _ <- clearSyncCacheProc 10 defaultCheck 100 + threadDelay 6000000 + putStrLn "after 6 seconds" + statElems >>= printStat + threadDelay 5000000 - 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" + putStrLn "after 11 seconds (should have saved)" + statElems >>= printStat + threadDelay 5000000 + + putStrLn "after 16 seconds (accessing one element)" + -- I read (access) all the data here! + getResource (Data 100 undefined) >>= print + + statElems >>= printStat + --syncCache + threadDelay 5000000 + + putStrLn "after 21 seconds (should have cleaned)" + statElems >>= printStat + + putStrLn "Updating every element, included the discarded ones with 'n 1'" withResources [Data i undefined | i <- [1..200]] $ \ds -> [ Data i (n+1) | Just(Data i n) <- ds] + threadDelay 5000000 - 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 + putStrLn "after 26 seconds (should be 'full')" + statElems >>= printStat + putStrLn "accessing all entries once and print the last" + -- I read (access) all the data here! + x2 <- getResources [Data i 1 | i <- [1..200]] + print $ last x2 + + threadDelay 5000000 + + putStrLn "after 31 seconds (should have saved)" + statElems >>= printStat + threadDelay 5000000 + + putStrLn "after 36 seconds" + statElems >>= printStat + threadDelay 5000000 + + putStrLn "after 41 seconds (should be cleaned again)" + statElems >>= printStat + + -- reloading all of the data again + putStrLn "getting the first 50 elements" + x <- getResources [Data i 1 | i <- [1..50]] + putStrLn $ "Last element: " ++ show (last x) + + putStrLn "Now we have" + statElems >>= printStat diff --git a/demos/indexQuery.hs b/demos/indexQuery.hs new file mode 100644 --- /dev/null +++ b/demos/indexQuery.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-} +module Main where +import Data.TCache +import Data.TCache.IndexQuery +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8(pack,unpack) +import Data.Typeable + +data Person= Person {pname :: String, age :: Int} 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 + +instance Serializable Person where + serialize = pack . show + deserialize = read . unpack + +instance Serializable Car where + serialize = pack . show + deserialize = read . unpack + +main :: IO () +main = do + + index owner + index pname + index cname + index age + + bruce <- atomically $ newDBRef $ Person "bruce" 42 + atomically $ mapM_ newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"] + + r1 <- atomically $ cname .>=. "Bat Mobile" + print r1 + + r2 <- atomically $ select (cname, owner) $ (owner .==. bruce) .&&. (cname .==. "Bat Mobile") + print r2 + + r3 <- atomically $ age .>=. (20 :: Int) + print r3 + + --syncCache diff --git a/demos/indexText.hs b/demos/indexText.hs new file mode 100644 --- /dev/null +++ b/demos/indexText.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Main where +import Data.TCache +import Data.TCache.DefaultPersistence +import Data.TCache.IndexQuery(select) +import Data.TCache.IndexText +import Data.ByteString.Lazy.Char8(pack,unpack) +import qualified Data.Text.Lazy as T(pack) +import Data.Typeable + +data Doc= Doc{title, body :: String} deriving (Read,Show, Typeable) +instance Indexable Doc where + key Doc{title=t}= t + +instance Serializable Doc where + serialize= pack . show + deserialize= read . unpack + +main :: IO () +main = do + indexText body T.pack + let doc= Doc{title= "title", body= "hola que tal estamos"} + rdoc <- atomically $ newDBRef doc + r1 <- atomically $ select title $ body `contains` "hola que tal" + print r1 + + atomically $ writeDBRef rdoc doc{ body= "que tal"} + r <- atomically $ select title $ body `contains` "hola que tal" + print r + if r1 == [title doc] then print "OK" else print "FAIL" + if null r then print "OK" else print "FAIL" diff --git a/demos/memoization.hs b/demos/memoization.hs --- a/demos/memoization.hs +++ b/demos/memoization.hs @@ -1,15 +1,18 @@ import Data.TCache.Memoization -import Data.TCache.DefaultPersistence import Control.Concurrent import System.Time - +-- | memoization caches a value for a given amount of time +-- This demo stores the current time for 4 seconds until +-- it generates the next timestamp -main= do - cachedByKey "key" 4 f >>= print - threadDelay 1000000 - main +main :: IO b +main = do + cachedByKey "timequant" 4 f >>= print + threadDelay 1000000 + main -f= do - TOD t _ <- getClockTime - return t +f :: IO Integer +f = do + TOD t _ <- getClockTime + return t diff --git a/demos/pr.hs b/demos/pr.hs new file mode 100644 --- /dev/null +++ b/demos/pr.hs @@ -0,0 +1,23 @@ +module Main where +import Data.TCache +import Data.Typeable +import Data.TCache.DefaultPersistence +import Data.ByteString.Lazy.Char8 + +data Ops= Plus | Times deriving (Read, Show, Typeable) + +instance Serializable Ops where + serialize= pack . show + deserialize= read . unpack + +instance Indexable Ops where + key _ = "ops" + +main :: IO () +main = do + let ref = getDBRef $ keyResource Times + atomically $ writeDBRef ref Plus + syncCache + + + print ref diff --git a/demos/pushpop.hs b/demos/pushpop.hs new file mode 100644 --- /dev/null +++ b/demos/pushpop.hs @@ -0,0 +1,58 @@ +import Data.Persistent.Collection +import Control.Concurrent +import Data.TCache + +main :: IO () +main = do + let q = getQRef "hi" + + -- display if and what we have in the queue + -- will be empty on first run but afterwards + -- contains "e" + pickAll q >>= print + + -- make sure there is no data left + flush q + + -- pop from empty would deadlock, so don't do that + -- pop q >>= print + + push q "a" -- push before starting asyncs + + -- async pops (first does not need to wait) + _ <- forkIO $ pop q >>= print + _ <- forkIO $ pop q >>= print + + putStrLn "Waiting a bit (should print \"a\")" + threadDelay 1000000 + putStrLn "By mpt \"a\" should be printed" + + -- push more + push q "b" -- this will be printed asap + + push q "c" + push q "d" -- will be sync popped + push q "e" -- will be left over at the end + + -- let the second fork finish + threadDelay 1000000 + putStrLn "By now \"b\" should be already printed" + + -- another async fork (printing "c") + _ <- forkIO $ pop q >>= print + + -- sync current state to file and print it + -- this usually still has "c" included + threadDelay 1000000 + syncCache + readFile ".tcachedata/Queue#hi" >>= putStrLn + + -- sync pop (usually prints "d") + pop q >>= print + + -- another sync / wait / print + syncCache + threadDelay 1000000 + -- here "e" will be left in the queue on Disk + readFile ".tcachedata/Queue#hi" >>= putStrLn + -- and stays there for the next run diff --git a/demos/testnewdbref.hs b/demos/testnewdbref.hs new file mode 100644 --- /dev/null +++ b/demos/testnewdbref.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleInstances + ,UndecidableInstances + ,DeriveDataTypeable + #-} + +import Data.TCache +import Data.TCache.DefaultPersistence +import Data.Typeable +import Data.ByteString.Lazy.Char8 as B + +type UserName= String + +data User= User + { userName :: UserName + , upassword :: String + } deriving (Read, Show, Typeable) + +userPrefix :: String +userPrefix= "User#" + +instance Indexable User where + key User{userName= user}= userPrefix++user + +userRegister :: String -> String -> IO(DBRef User) +userRegister user password = atomically $ newDBRef $ User user password + +instance (Show a, Read a) => Serializable a where + serialize = pack . show + deserialize = read . unpack + +main :: IO () +main = do + userRegister "test" "12345678" + print "(WIP)" diff --git a/demos/weakTest.hs b/demos/weakTest.hs new file mode 100644 --- /dev/null +++ b/demos/weakTest.hs @@ -0,0 +1,13 @@ +import System.Mem.Weak +import Debug.Trace + +debug :: c -> String -> c +debug = flip trace + +dat :: String +dat = "this is the data" + +main :: IO b +main = do + _ <- mkWeakPtr dat . Just $ print "deleted" `debug` "deleted" + main