diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,15 @@ +* 1.0.0 : Breaking changes (hence the major version): + - The name of the files of the indexes of `Data.TCache.IndexQuery` has changed: from `index-` to `index/-`. + The index files created by previous versions are not found by this one. + - `Show` of `DBRef` writes `DB# "key"` instead of `DBRef "key"`. `Read` accepts both formats, so the data written by previous + versions can be read, but the data written by this version can not be read by previous ones. + - The functions of `Data.TCache.IndexQuery` (`index`, `getIndex`, `join`, the relational operators...) and the instance + `IResource (Index reg a)` now require `Indexable reg`. + New: + - `referencedKeys`, a new method of `IResource` (default: no references): the keys of the DBRefs that a record contains. + - `syncDBRef`: saves a DBRef and, recursively, the DBRefs that it references (cycles are handled). + - `existDataForKey`: tells if there are data for a key, in the cache or in the permanent storage, without adding it to the cache. + Internal: `safeIOToSTM` uses `forkFinally`; `takeDBRef` reads the resource by key. * 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. diff --git a/Data/Persistent/Collection.hs b/Data/Persistent/Collection.hs --- a/Data/Persistent/Collection.hs +++ b/Data/Persistent/Collection.hs @@ -31,7 +31,7 @@ unreadSTM,isEmpty,isEmptySTM ) where import Data.Typeable -import Control.Concurrent.STM(STM,atomically, retry) +import Control.Concurrent.STM import Control.Monad import Data.TCache.DefaultPersistence diff --git a/Data/TCache.hs b/Data/TCache.hs --- a/Data/TCache.hs +++ b/Data/TCache.hs @@ -134,6 +134,7 @@ ,writeDBRef ,delDBRef + -- * @IResource@ class {- | Cached objects must be instances of `IResource`. Such instances can be implicitly derived trough auxiliary classes for file persistence. @@ -287,17 +288,21 @@ ,SyncMode(..) ,clearSyncCacheProc ,defaultCheck +,existDataForKey +,syncDBRef -- * Other ,onNothing ) where +import qualified Data.Set as Set + 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 Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef) import System.IO.Unsafe(unsafePerformIO) import System.IO(hPutStr, stderr) import Data.Maybe(catMaybes) @@ -312,8 +317,9 @@ 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 Control.Concurrent(forkFinally) +import Control.Exception(catch, handle, throw, evaluate, bracket, SomeException(..),throwIO) +import Data.Maybe --import Debug.Trace --(!>) = flip trace @@ -468,9 +474,12 @@ 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 ('D':'B':'#':' ':'\"':str2)= + let (key1,nstr) = break (== '\"') str2 + in [(getDBRef key1 :: DBRef a, tail nstr)] + readit ('D':'B':'R':'e':'f':' ':'\"':str2)= -- legacy format + let (key1,nstr) = break (== '\"') str2 + in [(getDBRef key1 :: DBRef a, tail nstr)] readit _ = [] -- | Return the key of the object referenced by the DBRef @@ -511,6 +520,26 @@ putMVar getRefFlag () return dbref +-- | ligtweight way to read an object without adding the reference to it to the cache if it does not exist. + +-- | Check whether data for a key exists in cache or in persistent storage. +-- Does not add anything to the cache. Pass a @Proxy a@ to fix the type. +existDataForKey :: (IResource a, Typeable a) => a -> String -> IO Bool +existDataForKey x k = do + (cache, _) <- readIORef refcache + mc <- H.lookup cache k + case mc of + Just (CacheElem _ w) -> do + mdbref <- deRefWeak w + case mdbref of + Just _ -> return True + Nothing -> checkDisk + Nothing -> checkDisk + where + checkDisk = isJust <$> (readResourceByKey k `asTypeOf` type1 x ) + type1 :: a -> IO(Maybe a) + type1= undefined + getRefFlag :: MVar () {-# NOINLINE getRefFlag #-} getRefFlag= unsafePerformIO $ newMVar () @@ -593,21 +622,48 @@ -- H.insert cache key ( CacheElem Nothing w) -- return dbref --- | Delete the content of the DBRef form the cache and from permanent storage +-- | Delete the content of the DBRef from 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 () +-- | Save a single DBRef and recursively all DBRefs referenced by its record, +-- as reported by 'referencedKeys'. Visited keys are tracked to handle cycles. +syncDBRef :: (IResource a, Typeable a) => DBRef a -> IO () +syncDBRef root = do + visited <- newIORef Set.empty + criticalSection saving $ go visited (keyObjDBRef root) + where + go visited key1 = do + seen <- readIORef visited + if Set.member key1 seen then return () else do + modifyIORef visited (Set.insert key1) + (cache, _) <- readIORef refcache + mc <- H.lookup cache key1 + case mc of + Nothing -> return () + Just (CacheElem _ w) -> do + mr <- deRefWeak w + case mr of + Nothing -> finalize w + Just (DBRef _ tv) -> do + r <- readTVarIO tv + case r of + Exist (Elem x _ _) -> do + writeResource x + mapM_ (go visited) (referencedKeys x) + _ -> return () + -- | Handles Nothing cases in a simpler way than runMaybeT. -- it is used in infix notation. for example: -- @@ -641,7 +697,7 @@ Nothing -> unsafeIOToSTM (finalize w) >> flushKey key1 Nothing -> return () --- | label the object as not existent in database +-- | label the object as non existent in database invalidateKey :: String -> STM () invalidateKey key1= do (cache, _) <- unsafeIOToSTM $ readIORef refcache @@ -764,20 +820,24 @@ takeDBRef :: (IResource a, Typeable a) => Ht -> CheckTPVarFlags -> a -> STM(Maybe (DBRef a)) takeDBRef cache flags x =do let keyr= keyResource x + takeDBRefByKey cache flags keyr + +takeDBRefByKey :: (IResource a, Typeable a) => Ht -> CheckTPVarFlags -> String -> STM(Maybe (DBRef a)) +takeDBRefByKey cache flags keyr = do 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 -> unsafeIOToSTM (finalize w) >> takeDBRefByKey cache flags keyr Nothing -> safeIOToSTM $ readToCache flags cache keyr -- unsafeIOToSTM $ readResourceByKey keyr where readToCache flags1 cache1 key1= do - mr <- readResource x + mr <- readResourceByKey key1 case mr of Nothing -> return Nothing Just r2 -> do @@ -1049,13 +1109,25 @@ -- 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 ) +safeIOToSTM req = unsafeIOToSTM $ do + tv <- newEmptyMVar + void $ forkFinally req $ \result -> putMVar tv result r <- takeMVar tv case r of - Right x -> return x - Left e -> throw e + Right x -> return x + Left e -> throwIO (SomeException e) +-- | when a STM transaction is retried, if the safeIOToSTM action changes as a result of the retry, +-- it is necessary to undo the effect before retry. the additional parameter is the compensation to be executed +-- when the IO action is interrupted by the STM transaction to perform a retry or when the IO action produces an error. +safeIOToSTMComp :: IO a -> IO () -> STM a +safeIOToSTMComp req reqCompensation = unsafeIOToSTM $ do + tv <- newEmptyMVar + forkFinally req $ \result -> + case result of + Right x -> putMVar tv (Right x) + Left e -> reqCompensation >> putMVar tv (Left e) + mr <- takeMVar tv + case mr of + Right r -> return r + Left e -> throwIO e diff --git a/Data/TCache/Defs.hs b/Data/TCache/Defs.hs --- a/Data/TCache/Defs.hs +++ b/Data/TCache/Defs.hs @@ -33,8 +33,13 @@ data DBRef a = DBRef !String !(TPVar a) deriving Typeable +-- WARNING: syncDBRef relies on referencedKeys, which for Serializable types is +-- typically implemented by parsing the serialized form for "DB# \"key\"" patterns. +-- Both "DB# \"key\"" (current) and "DBRef \"key\"" (legacy) must be matched. +-- String fields containing either literal will cause spurious cache lookups but +-- are otherwise harmless. instance Show (DBRef a) where - show (DBRef key1 _)= "DBRef \""++ key1 ++ "\"" + show (DBRef key1 _)= "DB# \""++ key1 ++ "\"" instance Eq (DBRef a) where DBRef k _ == DBRef k' _ = k == k' diff --git a/Data/TCache/IResource.hs b/Data/TCache/IResource.hs --- a/Data/TCache/IResource.hs +++ b/Data/TCache/IResource.hs @@ -66,6 +66,12 @@ delResources :: [a] -> IO() delResources= mapM_ delResource + + -- | Keys of DBRefs embedded in this resource. Used by 'syncDBRef' for recursive saves. + -- Override this to enable recursive sync; default returns no references. + referencedKeys :: a -> [String] + referencedKeys _ = [] + -- | Resources data definition used by 'withSTMResources' data Resources a b = Retry -- ^ forces a retry diff --git a/Data/TCache/IndexQuery.hs b/Data/TCache/IndexQuery.hs --- a/Data/TCache/IndexQuery.hs +++ b/Data/TCache/IndexQuery.hs @@ -106,7 +106,7 @@ , Typeable a,Ord a,PersistIndex reg) => Queriable reg a -instance Queriable reg a => IResource (Index reg a) where +instance (Indexable reg,Queriable reg a) => IResource (Index reg a) where keyResource = key writeResource =defWriteResource readResourceByKey = defReadResourceByKey @@ -133,23 +133,25 @@ keyIndex :: (Show a1, Show a2) => a1 -> a2 -> String -keyIndex treg tv= "index-" ++ show treg ++ show tv +keyIndex treg tv= "index/" ++ show treg <> "-" <> show tv -instance (Typeable reg, Typeable a) => Indexable (Index reg a) where +instance (Indexable reg, Typeable reg, Typeable a) => Indexable (Index reg a) where + defPath index= defPath (getType index) + where + getType :: Index reg a -> reg + getType= undefined + key map1= keyIndex typeofreg typeofa - where - [typeofreg, typeofa]= typeRepArgs $! typeOf map1 --- defPath index= defPath $ ofRegister index --- where --- ofRegister :: Index reg a -> reg --- ofRegister = undefined -- type level + where + [typeofreg, typeofa]= typeRepArgs $! typeOf map1 + -- instance (Queriable reg a, Typeable reg, Typeable a) => IResource (Index reg a) where -- keyResource = key -- writeResource =defWriteResource -- readResourceByKey = defReadResourceByKey -- delResource = defDelResource -getIndex :: (Queriable reg a) +getIndex :: (Indexable reg,Queriable reg a) => ( reg -> a) -> a -> STM(DBRef (Index reg a), Index reg a,[DBRef reg]) getIndex selector val= do let [one, two]= typeRepArgs $! typeOf selector @@ -157,7 +159,7 @@ getIndexr rindex val -getIndexr :: (Queriable reg a) +getIndexr :: (Indexable reg,Queriable reg a) => DBRef(Index reg a) -> a -> STM(DBRef (Index reg a), Index reg a,[DBRef reg]) getIndexr rindex val= do mindex <- readDBRef rindex @@ -165,19 +167,22 @@ 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 fields= show $ typeOf $ typ rindex + error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IdexQuery.index " <> fields <> "\" to start indexing this field" let dbrefs= case M.lookup val index of Just dbrefs -> dbrefs Nothing -> [] return (rindex, Index index, dbrefs) + where + typ :: DBRef (Index a b) -> b + typ = undefined selectorIndex - :: (Queriable reg a, IResource reg - ) => - (reg -> a) -> DBRef (Index reg a) -> DBRef reg -> Maybe reg -> STM () + :: (Queriable reg a, Indexable reg) => + (reg -> a) -> DBRef (Index reg a) -> + DBRef reg -> Maybe reg -> STM () selectorIndex selector rindex1 pobject mobj1 = do moldobj <- readDBRef pobject @@ -195,7 +200,7 @@ (Just oldobj, Nothing) -> do -- delete the old selector value from the index let val= selector oldobj - (rindex,Index index2, dbrefs) <- getIndexr rindex1 val + (rindex,Index index2, dbrefs) <- getIndexr rindex1 val let dbrefs'= Data.List.delete pobject dbrefs writeDBRef rindex $ Index (M.insert val dbrefs' index2) @@ -209,7 +214,7 @@ the indexed field can be used to perform relational-like searches -} -index :: (Queriable reg a) => (reg -> a) -> IO () +index :: (Indexable reg, Queriable reg a) => (reg -> a) -> IO () index sel= do let [one, two]= typeRepArgs $! typeOf sel rindex= getDBRef $! keyIndex one two @@ -236,7 +241,7 @@ -- Instance of relations betweeen fields and values -- field .op. value -instance (Queriable reg a) => RelationOps (reg -> a) a [DBRef reg] where +instance (Indexable reg, Queriable reg a) => RelationOps (reg -> a) a [DBRef reg] where (.==.) field value= do (_ ,_ ,dbrefs) <- getIndex field value return dbrefs @@ -247,7 +252,7 @@ (.>=.) field value= retrieve field value (>=) -join:: (Queriable rec v, Queriable rec' v) +join:: (Indexable rec,Queriable rec v, Indexable rec', Queriable rec' v) =>(v->v-> Bool) -> (rec -> v) -> (rec' -> v) -> STM[([DBRef rec], [DBRef rec'])] join op field1 field2 =do idxs <- indexOf field1 @@ -263,7 +268,7 @@ -- Instance of relations betweeen fields -- field1 .op. field2 -instance (Queriable reg a ,Queriable reg' a ) =>RelationOps (reg -> a) (reg' -> a) (JoinData reg reg') where +instance (Indexable reg,Queriable reg a ,Indexable reg', Queriable reg' a ) =>RelationOps (reg -> a) (reg' -> a) (JoinData reg reg') where (.==.)= join (==) (.>.) = join (>) @@ -318,7 +323,7 @@ -- | return all the (indexed) values which this field has and a DBRef pointer to the register -indexOf :: (Queriable reg a) => (reg -> a) -> STM [(a,[DBRef reg])] +indexOf :: (Indexable reg, Queriable reg a) => (reg -> a) -> STM [(a,[DBRef reg])] indexOf selector= do let [one, two]= typeRepArgs $! typeOf selector let rindex= getDBRef $! keyIndex one two @@ -329,11 +334,11 @@ let fields= show $ typeOf selector 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 :: (Indexable reg, Queriable reg a) => (reg -> a) -> a -> (a -> a -> Bool) -> STM[DBRef reg] retrieve field value op= do index1 <- indexOf field - let higuer = map (\(v, vals) -> if op v value then vals else []) index1 - return $ concat higuer + let higher = map (\(v, vals) -> if op v value then vals else []) index1 + return $ concat higher -- from a Query result, return the records, rather than the references recordsWith diff --git a/TCache.cabal b/TCache.cabal --- a/TCache.cabal +++ b/TCache.cabal @@ -1,5 +1,5 @@ name: TCache -version: 0.13.3 +version: 1.0.0 cabal-version: >= 1.10 synopsis: A Transactional cache with user-defined persistence description: Please see the README on GitHub at