{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable
    , FlexibleInstances, UndecidableInstances #-}

{- | TCache is a transactional cache with configurable persitence that permits
STM transactions with objects thar syncronize sincromous or asyncronously with
their user defined storages. Default persistence in files is provided for testing purposes

In this release some stuff has been supressed without losing functionality. Dynamic interfaces
are not needed since TCache can handle heterogeneous data.
The new things in this release, besides the backward compatible stuf are:

 TCache now implements. ''DBRef' 's . They are persistent STM references  with a traditional 'readDBRef', 'writeDBRef' Haskell interface.
simitar to TVars, but with aded. persistence
Additionally, because DBRefs are serializable, they can be embeded in serializable registers.
Because they are references,they point to other serializable registers.
This permits persistent mutable Inter-object relations

Triggers are user defined hooks that are called back on register updates. That can be used for:

   - ease the work of maintain actualized the inter-object relations

   - permit more higuer level and customizable accesses

"Data.TCache.IndexQuery" implements an straighforwards pure haskell type safe query language  based
 on register field relations. This module must be imported separately.
 see "Data.TCache.IndexQuery" for further information

The file persistence is now more reliable, and the embedded IO reads inside STM transactions are safe.

To ease the implementation of other user-defined persistence, "Data.TCache.FIlePersistence" must be imported
 for deriving file persistence instances


-}



 
module Data.TCache (
-- * Inherited from 'Control.Concurrent.STM'

 atomically
 ,STM

-- * 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.

DBRefs are references to  cached database objects. A DBRef is associated with its referred object and its key
Since DBRefs are serializable, they can be elements of mutable objects. 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 and so on.
The creation of a DBRef, trough 'getDBRef' is pure. This permits an efficient lazy marshalling
of registers with references, such are indexes when are queried for some fields but not others.

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 lookups everytime
in the cache

DBRef's and *Resource(s) primitives are completely interoperable. The latter operate implicitly with DBRef's

-}


,DBRef
,getDBRef
,keyObjDBRef
,newDBRef
--,newDBRefIO
,readDBRef
,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
{- | Operations with DBRef's can be performed implicitly with the \"traditional\" TCache operations
available in older versions.

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      -- empty resources
,withSTMResources
,Resources(..)  -- data definition used to communicate object Inserts and Deletes to the cache
,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
@

produces:

gives:

> main
> 2
> Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]}

-}

,addTrigger

-- * cache control
,flushDBRef
,flushAll
,Cache       
,setCache        
,newCache        
,refcache        
,syncCache
,setConditions
,clearSyncCache
,numElems
,clearSyncCacheProc  
,defaultCheck
-- * auxiliary file operations used for default persistence in files.
)
where 


import GHC.Conc
import Control.Monad(when)
import Data.HashTable as H
import Data.IORef
import System.IO.Unsafe
import System.IO(hPutStr, stderr)
import Data.Maybe(catMaybes,mapMaybe, fromMaybe, fromJust)

import Data.TCache.Defs
import Data.TCache.IResource
import Data.TCache.Triggers
import Control.Exception(handle,assert, bracket, SomeException)
import Data.Typeable
import System.Time
import System.Mem
import System.Mem.Weak
--import Debug.Trace

import Control.Concurrent.MVar


--debug = 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 = HashTable 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
refcache :: Cache  
refcache =unsafePerformIO $ newCache >>= newIORef

-- | newCache  creates a new cache. Experimental          
newCache  :: IO (Ht , Integer)
newCache =do
        c <- H.new (==) 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ś O(n).
numElems :: IO Int
numElems= do
   (cache, _) <- readIORef refcache
   elems <-   toList cache
   return $ length elems


deRefWeakSTM = unsafeIOToSTM . deRefWeak

deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO ()
deleteFromCache (DBRef k tv)=   do
    (cache, _) <- readIORef refcache
    H.delete cache k


-- | 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 t
           return $ Just  x

-- | 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
writeDBRef :: (IResource a, Typeable a)  => DBRef a -> a -> STM ()
writeDBRef dbref@(DBRef key  tv) x= 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 ('D':'B':'R':'e':'f':' ':'\"':str)=
       let (key,nstr) =  break (== '\"') str
       in  [( getDBRef key :: DBRef a, tail  nstr)]
    readsPrec _ _ = []

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.
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
  r <- H.lookup cache  key
  case r of
   Just (CacheElem  _ w) -> do
     mr <-  deRefWeak w
     case mr of
        Just dbref@(DBRef _  tv) -> return $ castErr dbref
        Nothing -> finalize w >>  getDBRef1 key  -- the weak pointer hasn executed his finalizer

   Nothing -> do
     tv<- newTVarIO NotRead
     let dbref= DBRef key  tv
     w <- mkWeakPtr  dbref . Just $ deleteFromCache dbref
     H.update cache key (CacheElem Nothing w)
     return  dbref
            
{- | Create the object passed as parameter (if it does not exist) and
-- return its reference in the IO monad.
-- If an object with the same key already exists, it is returned as is
-- 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 $ deleteFromCache dbref
     H.update 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))     -- ^ The 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

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 $ deleteFromCache dbref  
        H.update 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 $ bracket
       (takeMVar saving)
       (putMVar saving)
       $ const $ delResource x

   Nothing -> return ()

    		




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


-- | drops the entire cache.
flushAll :: STM ()
flushAll = do
 (cache,time) <- unsafeIOToSTM $ readIORef refcache
 elms <- unsafeIOToSTM $ toList cache
 mapM_ (del cache) elms
 where
 del cache ( _ , CacheElem _ w)= do
      mr <- unsafeIOToSTM $ deRefWeak w
      case mr of
        Just (DBRef _  tv) ->  writeTVar tv DoNotExist
        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'
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) as) (map Just as)
          applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing  `asTypeOf` (Just(head ds))))
          delListFromHash cache   ds
          releaseTPVars as cache

          safeIOToSTM $ bracket
             (takeMVar saving)
             (putMVar saving)
             $ const $ 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])@
withResource:: (IResource  a, Typeable a)
              => a                    -- ^ prototypes of the object to be retrieved for which keyResource can be derived
              -> (Maybe a-> a)      -- ^ update function that return another full object
              -> 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 [] ()@
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}@
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@
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] @
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) ()@
deleteResources :: (IResource a, Typeable a) => [a] -> IO ()
deleteResources rs= atomically $ withSTMResources rs f1 where
   f1 mrs = resources {toDelete=catMaybes mrs}
   

takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht  -> CheckTPVarFlags -> STM [Maybe (DBRef a)] 
takeDBRefs rs cache addToHash=  mapM (takeDBRef cache addToHash)  rs  



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 <- readResourceByKey key
       case mr of
            Nothing -> return Nothing
            Just r2 -> do
               ti  <-   timeInteger
               tvr <-   newTVarIO . Exist $ Elem r2 ti ti
               case flags of
                   NoAddToHash -> return . Just $ DBRef key  tvr
                   AddToHash   -> do
                      let dbref=  DBRef key  tvr
                      w <- mkWeakPtr  dbref . Just $ deleteFromCache dbref 
                      H.update cache key (CacheElem (Just dbref) w)
                      return $ Just dbref

      

                
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 key  tv) -> do
                    t <- unsafeIOToSTM  timeInteger
                    writeTVar tv . Exist  $ Elem  (castErr r)  t t	
				

	    Nothing   ->  do
	        ti  <- unsafeIOToSTM timeInteger
	        tvr <- newTVar . Exist $ Elem r ti ti
	        let dbref= DBRef keyr  tvr
	        w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ deleteFromCache dbref
	        unsafeIOToSTM $ H.update 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 _  tv) ->  writeTVar tv DoNotExist
        Nothing -> unsafeIOToSTM (finalize w) >> del  x

   

updateListToHash hash kv= mapM (update1 hash) kv where
	update1 h (k,v)= update h k v



-- | Start the thread that periodically call 'clearSyncCache' to clean and writes on the persistent storage. 
-- Otherwise, 'syncCache' must be invoked explicitly or no persistence will exist.
-- Cache writes allways save a coherent state
clearSyncCacheProc ::
         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 =handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do
    	threadDelay (fromIntegral$ time * 1000000)
    	clearSyncCache   check sizeObjects   --`debug` "CLEAR"
    	clear


 
-- | Force the atomic write of all cached objects modified since the last save into permanent storage
-- Cache writes allways save a coherent state
syncCache ::  IO ()
syncCache  = bracket
  (takeMVar saving)
  (putMVar saving)
  $ const $ do
      (cache,lastSync) <- readIORef refcache  --`debug` "syncCache"
      t2<- timeInteger
      elems <- toList cache
      (tosave,_,_) <- atomically $ extract elems lastSync
      save tosave
      writeIORef refcache (cache, t2)
  



-- |Saves the unsaved elems of the cache
-- Cache writes allways save a coherent state
--  delete some elems of  the cache when the number of elems > sizeObjects.
--  The deletion depends on the check criteria. 'defaultCheck' is the one implemented
clearSyncCache ::  (Integer -> Integer-> Integer-> Bool)-> Int -> IO ()
clearSyncCache check sizeObjects= bracket
  (takeMVar saving)
  (putMVar saving)
  $ const $ do
      (cache,lastSync) <- readIORef refcache
      t <- timeInteger
      elems <- 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.update cache key $ CacheElem Nothing w
                              writeTVar tv NotRead
            		      else return ()
    		_    ->  return()

       

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

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)

saving= unsafePerformIO $ newMVar False

save  tosave = do
     (pre, post) <-  readIORef refConditions
     pre
     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

            _ -> filter1 sav tofilter (n+1) rest


          
safeIOToSTM :: IO a -> STM a
safeIOToSTM req= unsafeIOToSTM  $ do
  tv   <- newEmptyMVar
  forkIO $ req >>= putMVar  tv
  takeMVar tv