TCache 0.13.3 → 1.0.0

raw patch · 7 files changed

+146/−46 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• Data/Persistent/Collection.hs +1/−1
• Data/TCache.hs +90/−18
• Data/TCache/Defs.hs +6/−1
• Data/TCache/IResource.hs +6/−0
• Data/TCache/IndexQuery.hs +30/−25
• TCache.cabal +1/−1

@@ -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-<type><field>` to `index/<type>-<field>`.+    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.  

@@ -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 

@@ -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

@@ -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'

@@ -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

@@ -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

@@ -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 <https://github.com/agocorona/TCache#readme>