{-# 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 :: Cache -> IO ()
setCache Cache
ref = forall a. IORef a -> IO a
readIORef Cache
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(HashTable RealWorld String CacheElem, Integer)
ch -> forall a. IORef a -> a -> IO ()
writeIORef Cache
refcache (HashTable RealWorld String CacheElem, Integer)
ch

-- | The cache holder. established by default
refcache :: Cache
{-# NOINLINE refcache #-}
refcache :: Cache
refcache =forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ IO (Ht, Integer)
newCache forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (IORef a)
newIORef

-- |   Creates a new cache. Experimental
newCache  :: IO (Ht , Integer)
newCache :: IO (Ht, Integer)
newCache =do
        HashTable RealWorld String CacheElem
c <- forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new  -- (==) H.hashString
        forall (m :: * -> *) a. Monad m => a -> m a
return (HashTable RealWorld String CacheElem
c,Integer
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 :: IO Int
numElems= do
   (HashTable RealWorld String CacheElem
cache, Integer
_) <- forall a. IORef a -> IO a
readIORef Cache
refcache
   [(String, CacheElem)]
elems <-   forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
H.toList HashTable RealWorld String CacheElem
cache
   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, CacheElem)]
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 :: IO (Int, Int, Int)
statElems = do
  (HashTable RealWorld String CacheElem
cache, Integer
lastSync) <- forall a. IORef a -> IO a
readIORef Cache
refcache
  [(String, CacheElem)]
clist <- forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
H.toList HashTable RealWorld String CacheElem
cache
  ([Filtered]
tosave, [CacheElem]
elems, Int
size) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a.
[(a, CacheElem)] -> Integer -> STM ([Filtered], [CacheElem], Int)
extract [(String, CacheElem)]
clist Integer
lastSync
  [Int]
counted <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. Num b => CacheElem -> IO b
count [CacheElem]
elems
  forall (m :: * -> *) a. Monad m => a -> m a
return (Int
size, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Filtered]
tosave, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
counted)
  where
    count :: CacheElem -> IO b
count (CacheElem Maybe (DBRef a)
_ Weak (DBRef a)
w) = do
      Maybe (DBRef a)
mr <- forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
      case Maybe (DBRef a)
mr of
        Just (DBRef String
_ TPVar a
tv) -> do
          Status (Elem a)
r <- forall a. TVar a -> IO a
readTVarIO TPVar a
tv
          case Status (Elem a)
r of
            Exist Elem {} -> forall (m :: * -> *) a. Monad m => a -> m a
return b
1
            Status (Elem a)
DoNotExist -> forall (m :: * -> *) a. Monad m => a -> m a
return b
0
            Status (Elem a)
NotRead -> forall (m :: * -> *) a. Monad m => a -> m a
return b
0
        Maybe (DBRef a)
Nothing -> forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return b
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 :: forall a. (IResource a, Typeable a) => DBRef a -> IO ()
fixToCache dbref :: DBRef a
dbref@(DBRef String
k TPVar a
_)= do
       (HashTable RealWorld String CacheElem
cache, Integer
_) <- forall a. IORef a -> IO a
readIORef Cache
refcache
       Weak (DBRef a)
w <- forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr DBRef a
dbref  forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (IResource a, Typeable a) => DBRef a -> IO ()
fixToCache DBRef a
dbref
       forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld String CacheElem
cache String
k (forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> Weak (DBRef a) -> CacheElem
CacheElem (forall a. a -> Maybe a
Just DBRef a
dbref) Weak (DBRef a)
w)
       forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef (DBRef String
key1  TPVar a
tv)= do
  Status (Elem a)
r <- forall a. TVar a -> STM a
readTVar TPVar a
tv
  case Status (Elem a)
r of
   Exist (Elem a
x Integer
_ Integer
mt) -> do
       Integer
t <- forall a. IO a -> STM a
unsafeIOToSTM IO Integer
timeInteger
       forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Status a
Exist forall a b. (a -> b) -> a -> b
$ forall a. a -> Integer -> Integer -> Elem a
Elem a
x Integer
t Integer
mt
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
   Status (Elem a)
DoNotExist -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
   Status (Elem a)
NotRead ->  do
       Maybe a
r1 <- forall a. IO a -> STM a
safeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. IResource a => String -> IO (Maybe a)
readResourceByKey String
key1
       case Maybe a
r1 of
         Maybe a
Nothing -> forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a. Status a
DoNotExist forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
         Just a
x  -> do
           Integer
t <- forall a. IO a -> STM a
unsafeIOToSTM IO Integer
timeInteger
           forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a b. (a -> b) -> a -> b
$ forall a. a -> Status a
Exist forall a b. (a -> b) -> a -> b
$ forall a. a -> Integer -> Integer -> Elem a
Elem  a
x Integer
t (-Integer
1)
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just  a
x

-- | Read multiple DBRefs in a single request using the new 'readResourcesByKey'
readDBRefs :: (IResource a, Typeable a)  => [DBRef a] -> STM [Maybe a]
readDBRefs :: forall a. (IResource a, Typeable a) => [DBRef a] -> STM [Maybe a]
readDBRefs [DBRef a]
dbrefs= do
  let mf :: DBRef a -> STM (Either String (Maybe a))
mf (DBRef String
key1  TPVar a
tv)= do
        Status (Elem a)
r <- forall a. TVar a -> STM a
readTVar TPVar a
tv
        case Status (Elem a)
r of
          Exist (Elem a
x Integer
_ Integer
mt) -> do
            Integer
t <- forall a. IO a -> STM a
unsafeIOToSTM IO Integer
timeInteger
            forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Status a
Exist forall a b. (a -> b) -> a -> b
$ forall a. a -> Integer -> Integer -> Elem a
Elem a
x Integer
t Integer
mt
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
          Status (Elem a)
DoNotExist -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
          Status (Elem a)
NotRead ->  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
key1
  [Either String (Maybe a)]
inCache <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. DBRef a -> STM (Either String (Maybe a))
mf [DBRef a]
dbrefs
  let pairs :: [(Either String (Maybe a), DBRef a)]
pairs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr(\pair :: (Either String (Maybe a), DBRef a)
pair@(Either String (Maybe a)
x,DBRef a
_) [(Either String (Maybe a), DBRef a)]
xs -> case Either String (Maybe a)
x of Left String
_ -> (Either String (Maybe a), DBRef a)
pairforall a. a -> [a] -> [a]
:[(Either String (Maybe a), DBRef a)]
xs; Either String (Maybe a)
_ -> [(Either String (Maybe a), DBRef a)]
xs ) [] forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Either String (Maybe a)]
inCache [DBRef a]
dbrefs
  let ([Either String (Maybe a)]
toReadKeys, [DBRef a]
dbrs) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Either String (Maybe a), DBRef a)]
pairs
  let fromLeft :: Either a b -> a
fromLeft (Left a
k)= a
k
      fromLeft Either a b
_ = forall a. HasCallStack => String -> a
error String
"this will never happen"
  [Maybe a]
rs <- forall a. IO a -> STM a
safeIOToSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IResource a => [String] -> IO [Maybe a]
readResourcesByKey forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. Either a b -> a
fromLeft [Either String (Maybe a)]
toReadKeys
  let processTVar :: (Maybe a, DBRef a) -> STM ()
processTVar (Maybe a
r, DBRef String
_ TPVar a
tv)=
        case Maybe a
r of
            Maybe a
Nothing -> forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a. Status a
DoNotExist
            Just a
x  -> do
              Integer
t <- forall a. IO a -> STM a
unsafeIOToSTM IO Integer
timeInteger
              forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a b. (a -> b) -> a -> b
$ forall a. a -> Status a
Exist forall a b. (a -> b) -> a -> b
$ forall a. a -> Integer -> Integer -> Elem a
Elem  a
x Integer
t (-Integer
1)

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. (Maybe a, DBRef a) -> STM ()
processTVar forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe a]
rs [DBRef a]
dbrs
  let mix :: [Either a a] -> [a] -> [a]
mix (Right a
x:[Either a a]
xs) [a]
ys   = a
xforall a. a -> [a] -> [a]
:[Either a a] -> [a] -> [a]
mix [Either a a]
xs [a]
ys
      mix (Left a
_:[Either a a]
xs) (a
y:[a]
ys)= a
yforall a. a -> [a] -> [a]
:[Either a a] -> [a] -> [a]
mix [Either a a]
xs [a]
ys
      mix [] [a]
_ = forall a. HasCallStack => String -> a
error String
"this will never happen(?)"
      mix (Left a
_:[Either a a]
_) [] = forall a. HasCallStack => String -> a
error String
"this will never happen(?)"

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a} {a}. [Either a a] -> [a] -> [a]
mix [Either String (Maybe a)]
inCache [Maybe a]
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 :: forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef dbref :: DBRef a
dbref@(DBRef String
key1  TPVar a
tv) a
x= a
x seq :: forall a b. a -> b -> b
`seq` do
 let newkey :: String
newkey= forall a. IResource a => a -> String
keyResource a
x
 if String
newkey forall a. Eq a => a -> a -> Bool
/= String
key1
   then  forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"writeDBRef: law of key conservation broken: old , new= " forall a. [a] -> [a] -> [a]
++ String
key1 forall a. [a] -> [a] -> [a]
++ String
" , "forall a. [a] -> [a] -> [a]
++String
newkey
   else do
    forall a.
(IResource a, Typeable a) =>
[DBRef a] -> [Maybe a] -> STM ()
applyTriggers  [DBRef a
dbref] [forall a. a -> Maybe a
Just a
x]
    Integer
t <- forall a. IO a -> STM a
unsafeIOToSTM IO Integer
timeInteger

    forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a b. (a -> b) -> a -> b
$! forall a. a -> Status a
Exist forall a b. (a -> b) -> a -> b
$! forall a. a -> Integer -> Integer -> Elem a
Elem a
x Integer
t Integer
t
    forall (m :: * -> *) a. Monad m => a -> m a
return()

instance  (IResource a, Typeable a) => Read (DBRef a) where
    readsPrec :: Int -> ReadS (DBRef a)
readsPrec Int
_ String
str1= ReadS (DBRef a)
readit String
str
       where
       str :: String
str = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
str1
       readit :: ReadS (DBRef a)
readit (Char
'D':Char
'B':Char
'R':Char
'e':Char
'f':Char
' ':Char
'\"':String
str2)=
         let   (String
key1,String
nstr) =  forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'\"') String
str2
         in  [( forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef String
key1 :: DBRef a, forall a. [a] -> [a]
tail  String
nstr)]
       readit  String
_ = []

-- | Return the key of the object referenced by the DBRef
keyObjDBRef ::  DBRef a -> String
keyObjDBRef :: forall a. DBRef a -> String
keyObjDBRef (DBRef String
k TPVar a
_)= String
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 :: forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef String
key1 =   forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$! forall a. (Typeable a, IResource a) => String -> IO (DBRef a)
getDBRef1 forall a b. (a -> b) -> a -> b
$! String
key1 where
 getDBRef1 :: (Typeable a, IResource a) =>  String -> IO (DBRef a)
 getDBRef1 :: forall a. (Typeable a, IResource a) => String -> IO (DBRef a)
getDBRef1 String
key2 = do
  (HashTable RealWorld String CacheElem
cache,Integer
_) <-  forall a. IORef a -> IO a
readIORef Cache
refcache   -- !> ("getDBRef "++ key)
  forall a. MVar a -> IO a
takeMVar MVar ()
getRefFlag
  Maybe CacheElem
r <- forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld String CacheElem
cache  String
key2
  case Maybe CacheElem
r of
   Just (CacheElem  Maybe (DBRef a)
mdb Weak (DBRef a)
w) -> do
     forall a. MVar a -> a -> IO ()
putMVar MVar ()
getRefFlag ()
     Maybe (DBRef a)
mr <-  forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
     case Maybe (DBRef a)
mr of
        Just dbref :: DBRef a
dbref@(DBRef String
_ TPVar a
_) ->
                case Maybe (DBRef a)
mdb of
                  Maybe (DBRef a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a1 a2. (Typeable a1, Typeable a2) => a1 -> a2
castErr DBRef a
dbref     -- !> "just"
                  Just DBRef a
_  -> do
                        forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld String CacheElem
cache String
key2 (forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> Weak (DBRef a) -> CacheElem
CacheElem forall a. Maybe a
Nothing Weak (DBRef a)
w) --to notify when the DBREf leave its reference
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a1 a2. (Typeable a1, Typeable a2) => a1 -> a2
castErr DBRef a
dbref
        Maybe (DBRef a)
Nothing -> forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  forall a. (Typeable a, IResource a) => String -> IO (DBRef a)
getDBRef1 String
key2          -- !> "finalize"  -- the weak pointer has not executed his finalizer

   Maybe CacheElem
Nothing -> do
     TVar (Status (Elem a))
tv <- forall a. a -> IO (TVar a)
newTVarIO forall a. Status a
NotRead                              -- !> "Nothing"
     DBRef a
dbref <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. String -> TPVar a -> DBRef a
DBRef String
key2  TVar (Status (Elem a))
tv
     Weak (DBRef a)
w <- forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr  DBRef a
dbref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (IResource a, Typeable a) => DBRef a -> IO ()
fixToCache DBRef a
dbref
     forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld String CacheElem
cache String
key2 (forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> Weak (DBRef a) -> CacheElem
CacheElem forall a. Maybe a
Nothing Weak (DBRef a)
w)
     forall a. MVar a -> a -> IO ()
putMVar MVar ()
getRefFlag ()
     forall (m :: * -> *) a. Monad m => a -> m a
return  DBRef a
dbref

getRefFlag :: MVar ()
{-# NOINLINE getRefFlag #-}
getRefFlag :: MVar ()
getRefFlag= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
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 :: forall a. (IResource a, Typeable a) => a -> STM (DBRef a)
newDBRef a
x = do
  let ref :: DBRef a
ref= forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef forall a b. (a -> b) -> a -> b
$! forall a. IResource a => a -> String
keyResource a
x

  Maybe a
mr <- forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef  DBRef a
ref
  case Maybe a
mr of
    Maybe a
Nothing -> forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef DBRef a
ref a
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return DBRef a
ref -- !> " write"
    Just a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return DBRef a
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 :: forall a. (IResource a, Typeable a) => DBRef a -> STM ()
delDBRef dbref :: DBRef a
dbref@(DBRef String
_ TPVar a
tv)= do
  Maybe a
mr <- forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef DBRef a
dbref
  case Maybe a
mr of
   Just a
x -> do
     forall a.
(IResource a, Typeable a) =>
[DBRef a] -> [Maybe a] -> STM ()
applyTriggers [DBRef a
dbref] [forall a. Maybe a
Nothing]
     forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a. Status a
DoNotExist

     forall a. IO a -> STM a
safeIOToSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c. MVar b -> IO c -> IO c
criticalSection MVar Bool
saving forall a b. (a -> b) -> a -> b
$ forall a. IResource a => a -> IO ()
delResource a
x

   Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall (m :: * -> *) b. Monad m => m (Maybe b) -> m b -> m b
onNothing m (Maybe b)
io m b
onerr= do
  Maybe b
my <-  m (Maybe b)
io
  case Maybe b
my of
   Just b
y -> forall (m :: * -> *) a. Monad m => a -> m a
return b
y
   Maybe b
Nothing -> m b
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 :: forall a. (IResource a, Typeable a) => DBRef a -> STM ()
flushDBRef (DBRef String
_ TPVar a
tv)=   forall a. TVar a -> a -> STM ()
writeTVar  TPVar a
tv  forall a. Status a
NotRead

-- | flush the element with the given key
flushKey :: String -> STM ()
flushKey :: String -> STM ()
flushKey String
key1=  do
   (HashTable RealWorld String CacheElem
cache, Integer
_) <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef Cache
refcache
   Maybe CacheElem
c <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld String CacheElem
cache String
key1
   case Maybe CacheElem
c of
       Just  (CacheElem Maybe (DBRef a)
_ Weak (DBRef a)
w) -> do
          Maybe (DBRef a)
mr <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
          case Maybe (DBRef a)
mr of
            Just (DBRef String
_ TPVar a
tv) -> forall a. TVar a -> a -> STM ()
writeTVar  TPVar a
tv  forall a. Status a
NotRead
            Maybe (DBRef a)
Nothing -> forall a. IO a -> STM a
unsafeIOToSTM (forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w)  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> STM ()
flushKey String
key1
       Maybe CacheElem
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | label the object as not existent in database
invalidateKey :: String -> STM ()
invalidateKey :: String -> STM ()
invalidateKey String
key1=  do
   (HashTable RealWorld String CacheElem
cache, Integer
_) <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef Cache
refcache
   Maybe CacheElem
c <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld String CacheElem
cache String
key1
   case Maybe CacheElem
c of
       Just  (CacheElem Maybe (DBRef a)
_ Weak (DBRef a)
w) -> do
          Maybe (DBRef a)
mr <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
          case Maybe (DBRef a)
mr of
            Just (DBRef String
_ TPVar a
tv) -> forall a. TVar a -> a -> STM ()
writeTVar  TPVar a
tv  forall a. Status a
DoNotExist
            Maybe (DBRef a)
Nothing -> forall a. IO a -> STM a
unsafeIOToSTM (forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w)  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> STM ()
flushKey String
key1
       Maybe CacheElem
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | drops the entire cache.
flushAll :: STM ()
flushAll :: STM ()
flushAll = do
 (HashTable RealWorld String CacheElem
cache, Integer
_) <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef Cache
refcache
 [(String, CacheElem)]
elms <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
H.toList HashTable RealWorld String CacheElem
cache
 forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. (a, CacheElem) -> STM ()
del [(String, CacheElem)]
elms
 where
 del :: (a, CacheElem) -> STM ()
del ( a
_ , CacheElem Maybe (DBRef a)
_ Weak (DBRef a)
w)= do
      Maybe (DBRef a)
mr <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
      case Maybe (DBRef a)
mr of
        Just (DBRef String
_  TPVar a
tv) ->  forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a. Status a
NotRead
        Maybe (DBRef a)
Nothing -> forall a. IO a -> STM a
unsafeIOToSTM (forall v. Weak v -> IO ()
finalize Weak (DBRef a)
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 :: forall a x.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> Resources a x) -> STM x
withSTMResources [a]
rs [Maybe a] -> Resources a x
f = do
  (HashTable RealWorld String CacheElem
cache, Integer
_) <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef Cache
refcache
  [Maybe (DBRef a)]
mtrs <- forall a.
(IResource a, Typeable a) =>
[a] -> Ht -> CheckTPVarFlags -> STM [Maybe (DBRef a)]
takeDBRefs [a]
rs HashTable RealWorld String CacheElem
cache CheckTPVarFlags
AddToHash
  [Maybe a]
mrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> STM (Maybe a)
mreadDBRef [Maybe (DBRef a)]
mtrs
  case [Maybe a] -> Resources a x
f [Maybe a]
mrs of
    Resources a x
Retry -> forall a. STM a
retry
    Resources [a]
as [a]
ds x
r -> do
      forall a.
(IResource a, Typeable a) =>
[DBRef a] -> [Maybe a] -> STM ()
applyTriggers (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IResource a => a -> String
keyResource) [a]
ds) (forall a. a -> [a]
repeat (forall a. Maybe a
Nothing forall a. a -> a -> a
`asTypeOf` forall a. a -> Maybe a
Just (forall a. [a] -> a
head [a]
ds)))
      forall a. IResource a => Ht -> [a] -> STM ()
delListFromHash HashTable RealWorld String CacheElem
cache [a]
ds
      forall a. (IResource a, Typeable a) => [a] -> Ht -> STM ()
releaseTPVars [a]
as HashTable RealWorld String CacheElem
cache
      forall a. IO a -> STM a
safeIOToSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c. MVar b -> IO c -> IO c
criticalSection MVar Bool
saving forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. IResource a => a -> IO ()
delResource [a]
ds
      forall (m :: * -> *) a. Monad m => a -> m a
return x
r
  where
    mreadDBRef :: (IResource a, Typeable a) => Maybe (DBRef a) -> STM (Maybe a)
    mreadDBRef :: forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> STM (Maybe a)
mreadDBRef (Just DBRef a
dbref) = forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef DBRef a
dbref
    mreadDBRef Maybe (DBRef a)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
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 :: forall a. (IResource a, Typeable a) => a -> (Maybe a -> a) -> IO ()
withResource a
r Maybe a -> a
f= forall a.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> [a]) -> IO ()
withResources [a
r] (\[Maybe a
mr]-> [Maybe a -> a
f Maybe a
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 :: forall a.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> [a]) -> IO ()
withResources [a]
rs [Maybe a] -> [a]
f = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a x.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> Resources a x) -> STM x
withSTMResources [a]
rs [Maybe a] -> Resources a ()
f1)
  where
    f1 :: [Maybe a] -> Resources a ()
f1 [Maybe a]
mrs =
      let as :: [a]
as = [Maybe a] -> [a]
f [Maybe a]
mrs
       in forall a b. [a] -> [a] -> b -> Resources a b
Resources [a]
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 :: forall a. (IResource a, Typeable a) => a -> IO (Maybe a)
getResource a
r= do{[Maybe a]
mr<- forall a. (IResource a, Typeable a) => [a] -> IO [Maybe a]
getResources [a
r];forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. [a] -> a
head [Maybe a]
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 :: forall a. (IResource a, Typeable a) => [a] -> IO [Maybe a]
getResources [a]
rs= forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a x.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> Resources a x) -> STM x
withSTMResources [a]
rs forall {b} {a}. b -> Resources a b
f1 where
  f1 :: b -> Resources a b
f1 = forall a b. [a] -> [a] -> b -> Resources a b
Resources  [] []


-- | Delete the   resource from cache and from persistent storage.
--
-- @ deleteResource r= 'deleteResources' [r] @
{-# INLINE deleteResource #-}
deleteResource :: (IResource a, Typeable a) => a -> IO ()
deleteResource :: forall a. (IResource a, Typeable a) => a -> IO ()
deleteResource a
r= forall a. (IResource a, Typeable a) => [a] -> IO ()
deleteResources [a
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 :: forall a. (IResource a, Typeable a) => [a] -> IO ()
deleteResources [a]
rs= forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a x.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> Resources a x) -> STM x
withSTMResources [a]
rs forall {a}. [Maybe a] -> Resources a ()
f1 where
   f1 :: [Maybe a] -> Resources a ()
f1 [Maybe a]
mrs = forall a. Resources a ()
resources {toDelete :: [a]
toDelete=forall a. [Maybe a] -> [a]
catMaybes [Maybe a]
mrs}

{-# INLINE takeDBRefs #-}
takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht  -> CheckTPVarFlags -> STM [Maybe (DBRef a)]
takeDBRefs :: forall a.
(IResource a, Typeable a) =>
[a] -> Ht -> CheckTPVarFlags -> STM [Maybe (DBRef a)]
takeDBRefs [a]
rs Ht
cache CheckTPVarFlags
addToHash=  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
(IResource a, Typeable a) =>
Ht -> CheckTPVarFlags -> a -> STM (Maybe (DBRef a))
takeDBRef Ht
cache CheckTPVarFlags
addToHash)  [a]
rs


{-# NOINLINE takeDBRef #-}
takeDBRef :: (IResource a, Typeable a) =>  Ht  -> CheckTPVarFlags -> a -> STM(Maybe (DBRef a))
takeDBRef :: forall a.
(IResource a, Typeable a) =>
Ht -> CheckTPVarFlags -> a -> STM (Maybe (DBRef a))
takeDBRef Ht
cache CheckTPVarFlags
flags a
x =do
   let  keyr :: String
keyr= forall a. IResource a => a -> String
keyResource a
x
   Maybe CacheElem
c <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup Ht
cache String
keyr
   case Maybe CacheElem
c of
       Just  (CacheElem Maybe (DBRef a)
_ Weak (DBRef a)
w) -> do
          Maybe (DBRef a)
mr <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
          case Maybe (DBRef a)
mr of
            Just DBRef a
dbref -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall a1 a2. (Typeable a1, Typeable a2) => a1 -> a2
castErr DBRef a
dbref
            Maybe (DBRef a)
Nothing -> forall a. IO a -> STM a
unsafeIOToSTM (forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w)  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a.
(IResource a, Typeable a) =>
Ht -> CheckTPVarFlags -> a -> STM (Maybe (DBRef a))
takeDBRef Ht
cache CheckTPVarFlags
flags a
x
       Maybe CacheElem
Nothing   ->
           forall a. IO a -> STM a
safeIOToSTM forall a b. (a -> b) -> a -> b
$ forall {h :: * -> * -> * -> *}.
HashTable h =>
CheckTPVarFlags
-> h RealWorld String CacheElem -> String -> IO (Maybe (DBRef a))
readToCache CheckTPVarFlags
flags Ht
cache  String
keyr
              -- unsafeIOToSTM $ readResourceByKey keyr

   where
   readToCache :: CheckTPVarFlags
-> h RealWorld String CacheElem -> String -> IO (Maybe (DBRef a))
readToCache CheckTPVarFlags
flags1 h RealWorld String CacheElem
cache1 String
key1= do
       Maybe a
mr <- forall a. IResource a => a -> IO (Maybe a)
readResource a
x
       case Maybe a
mr of
            Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just a
r2 -> do
               Integer
ti  <-   IO Integer
timeInteger
               TVar (Status (Elem a))
tvr <-   forall a. a -> IO (TVar a)
newTVarIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Status a
Exist forall a b. (a -> b) -> a -> b
$ forall a. a -> Integer -> Integer -> Elem a
Elem a
r2 Integer
ti (-Integer
1)
               case CheckTPVarFlags
flags1 of
                   CheckTPVarFlags
NoAddToHash -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. String -> TPVar a -> DBRef a
DBRef String
key1  TVar (Status (Elem a))
tvr
                   CheckTPVarFlags
AddToHash   -> do
                      DBRef a
dbref <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. String -> TPVar a -> DBRef a
DBRef String
key1  TVar (Status (Elem a))
tvr
                      Weak (DBRef a)
w <- forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr  DBRef a
dbref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (IResource a, Typeable a) => DBRef a -> IO ()
fixToCache DBRef a
dbref
                      forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert h RealWorld String CacheElem
cache1 String
key1 (forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> Weak (DBRef a) -> CacheElem
CacheElem (forall a. a -> Maybe a
Just DBRef a
dbref) Weak (DBRef a)
w)
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just DBRef a
dbref
     -- !> ("readToCache "++ key)



timeInteger :: IO Integer
timeInteger :: IO Integer
timeInteger= do TOD Integer
t Integer
_ <- IO ClockTime
getClockTime
                forall (m :: * -> *) a. Monad m => a -> m a
return Integer
t





releaseTPVars :: (IResource a,Typeable a)=> [a] -> Ht  -> STM ()
releaseTPVars :: forall a. (IResource a, Typeable a) => [a] -> Ht -> STM ()
releaseTPVars [a]
rs Ht
cache = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_  (forall a. (IResource a, Typeable a) => Ht -> a -> STM ()
releaseTPVar Ht
cache)  [a]
rs

releaseTPVar :: (IResource a,Typeable a)=>  Ht -> a  -> STM ()
releaseTPVar :: forall a. (IResource a, Typeable a) => Ht -> a -> STM ()
releaseTPVar Ht
cache  a
r =do
        Maybe CacheElem
c <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup Ht
cache String
keyr
        case Maybe CacheElem
c of
            Just  (CacheElem    Maybe (DBRef a)
_ Weak (DBRef a)
w) -> do
                Maybe (DBRef a)
mr <-  forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
                case Maybe (DBRef a)
mr of
                    Maybe (DBRef a)
Nothing -> forall a. IO a -> STM a
unsafeIOToSTM (forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. (IResource a, Typeable a) => Ht -> a -> STM ()
releaseTPVar Ht
cache  a
r
                    Just dbref :: DBRef a
dbref@(DBRef String
_  TPVar a
tv) -> do
                      forall a.
(IResource a, Typeable a) =>
[DBRef a] -> [Maybe a] -> STM ()
applyTriggers [DBRef a
dbref] [forall a. a -> Maybe a
Just (forall a1 a2. (Typeable a1, Typeable a2) => a1 -> a2
castErr a
r)]
                      Integer
t <- forall a. IO a -> STM a
unsafeIOToSTM  IO Integer
timeInteger
                      forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Status a
Exist  forall a b. (a -> b) -> a -> b
$ forall a. a -> Integer -> Integer -> Elem a
Elem  (forall a1 a2. (Typeable a1, Typeable a2) => a1 -> a2
castErr a
r)  Integer
t Integer
t


            Maybe CacheElem
Nothing   ->  do
                Integer
ti  <- forall a. IO a -> STM a
unsafeIOToSTM IO Integer
timeInteger
                TVar (Status (Elem a))
tvr <- forall a. a -> STM (TVar a)
newTVar forall a. Status a
NotRead
                DBRef a
dbref <- forall a. IO a -> STM a
unsafeIOToSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. String -> TPVar a -> DBRef a
DBRef String
keyr  TVar (Status (Elem a))
tvr
                forall a.
(IResource a, Typeable a) =>
[DBRef a] -> [Maybe a] -> STM ()
applyTriggers [DBRef a
dbref] [forall a. a -> Maybe a
Just a
r]
                forall a. TVar a -> a -> STM ()
writeTVar TVar (Status (Elem a))
tvr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Status a
Exist forall a b. (a -> b) -> a -> b
$ forall a. a -> Integer -> Integer -> Elem a
Elem a
r Integer
ti Integer
ti
                Weak (DBRef a)
w <- forall a. IO a -> STM a
unsafeIOToSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr DBRef a
dbref forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (IResource a, Typeable a) => DBRef a -> IO ()
fixToCache DBRef a
dbref
                forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert Ht
cache String
keyr (forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> Weak (DBRef a) -> CacheElem
CacheElem (forall a. a -> Maybe a
Just DBRef a
dbref) Weak (DBRef a)
w)-- accesed and modified XXX
                forall (m :: * -> *) a. Monad m => a -> m a
return ()


        where keyr :: String
keyr= forall a. IResource a => a -> String
keyResource a
r




delListFromHash :: IResource a => Ht -> [a] -> STM ()
delListFromHash :: forall a. IResource a => Ht -> [a] -> STM ()
delListFromHash Ht
cache= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. IResource a => a -> STM ()
del
 where
 del :: IResource a => a -> STM ()
 del :: forall a. IResource a => a -> STM ()
del a
x= do
   let key1 :: String
key1= forall a. IResource a => a -> String
keyResource a
x
   Maybe CacheElem
mr <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup Ht
cache String
key1
   case Maybe CacheElem
mr of
     Maybe CacheElem
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
     Just (CacheElem Maybe (DBRef a)
_ Weak (DBRef a)
w) -> do
      Maybe (DBRef a)
mr1 <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
      case Maybe (DBRef a)
mr1 of
        Just (DBRef String
_  TPVar a
tv) ->
           forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a. Status a
DoNotExist
        Maybe (DBRef a)
Nothing ->
          forall a. IO a -> STM a
unsafeIOToSTM (forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. IResource a => a -> STM ()
del  a
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 :: Int
-> (Integer -> Integer -> Integer -> Bool) -> Int -> IO ThreadId
clearSyncCacheProc  Int
time Integer -> Integer -> Integer -> Bool
check1 Int
sizeObjects= IO () -> IO ThreadId
forkIO  forall {b}. IO b
clear
 where
 clear :: IO b
clear = do
     Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
time forall a. Num a => a -> a -> a
* Int
1000000
     forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ( \ (SomeException
e :: SomeException)-> Handle -> String -> IO ()
hPutStr Handle
stderr (forall a. Show a => a -> String
show SomeException
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
clear ) forall a b. (a -> b) -> a -> b
$ do
            (Integer -> Integer -> Integer -> Bool) -> Int -> IO ()
clearSyncCache   Integer -> Integer -> Integer -> Bool
check1 Int
sizeObjects                                        -- !>  "CLEAR"
            IO b
clear

criticalSection :: MVar b -> IO c -> IO c
criticalSection :: forall b c. MVar b -> IO c -> IO c
criticalSection MVar b
mv IO c
f= forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
  (forall a. MVar a -> IO a
takeMVar MVar b
mv)
  (forall a. MVar a -> a -> IO ()
putMVar MVar b
mv)
  forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const IO c
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 :: IO ()
syncCache  = forall b c. MVar b -> IO c -> IO c
criticalSection MVar Bool
saving forall a b. (a -> b) -> a -> b
$ do
      (HashTable RealWorld String CacheElem
cache,Integer
lastSync) <- forall a. IORef a -> IO a
readIORef Cache
refcache  --`debug` "syncCache"
      Integer
t2<- IO Integer
timeInteger
      [(String, CacheElem)]
elems <- forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
H.toList HashTable RealWorld String CacheElem
cache
      ([Filtered]
tosave,[CacheElem]
_,Int
_) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a.
[(a, CacheElem)] -> Integer -> STM ([Filtered], [CacheElem], Int)
extract [(String, CacheElem)]
elems Integer
lastSync
      forall (t :: * -> *). Foldable t => t Filtered -> IO ()
save [Filtered]
tosave
      forall a. IORef a -> a -> IO ()
writeIORef Cache
refcache (HashTable RealWorld String CacheElem
cache, Integer
t2)


data SyncMode= Synchronous   -- ^ sync state to permanent storage when `atomicallySync` is invoked
             | Asynchronous
                  {SyncMode -> Int
frequency  :: Int                     -- ^ number of seconds between saves when asynchronous
                  ,SyncMode -> Integer -> Integer -> Integer -> Bool
check      :: Integer-> Integer-> Integer-> Bool  -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example
                  ,SyncMode -> Int
cacheSize  :: Int                     -- ^ size of the cache when async
                  }
             | SyncManual               -- ^ use `syncCache` to write the state




{-# NOINLINE tvSyncWrite #-}
tvSyncWrite :: IORef (SyncMode, Maybe a)
tvSyncWrite :: forall a. IORef (SyncMode, Maybe a)
tvSyncWrite= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef  (SyncMode
Synchronous, forall a. Maybe a
Nothing)

-- | Specify the cache synchronization policy with permanent storage. See `SyncMode` for details
syncWrite::  SyncMode -> IO()
syncWrite :: SyncMode -> IO ()
syncWrite SyncMode
mode = do
  (SyncMode
_, Maybe ThreadId
thread) <- forall a. IORef a -> IO a
readIORef forall a. IORef (SyncMode, Maybe a)
tvSyncWrite
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ThreadId
thread ThreadId -> IO ()
killThread
  case SyncMode
mode of
    SyncMode
Synchronous -> IO ()
modeWrite
    SyncMode
SyncManual -> IO ()
modeWrite
    Asynchronous Int
time Integer -> Integer -> Integer -> Bool
check1 Int
maxsize -> do
      ()
th <- forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Int
-> (Integer -> Integer -> Integer -> Bool) -> Int -> IO ThreadId
clearSyncCacheProc Int
time Integer -> Integer -> Integer -> Bool
check1 Int
maxsize
      forall a. IORef a -> a -> IO ()
writeIORef forall a. IORef (SyncMode, Maybe a)
tvSyncWrite (SyncMode
mode, forall a. a -> Maybe a
Just ()
th)
  where
    modeWrite :: IO ()
modeWrite = forall a. IORef a -> a -> IO ()
writeIORef forall a. IORef (SyncMode, Maybe a)
tvSyncWrite (SyncMode
mode, forall a. Maybe a
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 :: forall a. STM a -> IO a
atomicallySync STM a
proc=do
   a
r <- forall a. STM a -> IO a
atomically  STM a
proc
   IO ()
sync
   forall (m :: * -> *) a. Monad m => a -> m a
return a
r

   where
   sync :: IO ()
sync= do
       (SyncMode
savetype,Maybe Any
_) <- forall a. IORef a -> IO a
readIORef forall a. IORef (SyncMode, Maybe a)
tvSyncWrite
       case  SyncMode
savetype of
        SyncMode
Synchronous -> IO ()
syncCache
        SyncMode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
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 :: (Integer -> Integer -> Integer -> Bool) -> Int -> IO ()
clearSyncCache Integer -> Integer -> Integer -> Bool
check1 Int
sizeObjects= forall b c. MVar b -> IO c -> IO c
criticalSection MVar Bool
saving forall a b. (a -> b) -> a -> b
$ do
      (HashTable RealWorld String CacheElem
cache,Integer
lastSync) <- forall a. IORef a -> IO a
readIORef Cache
refcache
      Integer
t <- IO Integer
timeInteger
      [(String, CacheElem)]
elems <- forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
H.toList HashTable RealWorld String CacheElem
cache
      ([Filtered]
tosave, [CacheElem]
elems1, Int
size) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a.
[(a, CacheElem)] -> Integer -> STM ([Filtered], [CacheElem], Int)
extract [(String, CacheElem)]
elems Integer
lastSync
      forall (t :: * -> *). Foldable t => t Filtered -> IO ()
save [Filtered]
tosave
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size forall a. Ord a => a -> a -> Bool
> Int
sizeObjects) forall a b. (a -> b) -> a -> b
$  IO () -> IO ThreadId
forkIO (forall {t :: * -> *} {h :: * -> * -> * -> *}.
(Foldable t, HashTable h) =>
Integer
-> h RealWorld String CacheElem -> Integer -> t CacheElem -> IO ()
filtercache Integer
t HashTable RealWorld String CacheElem
cache Integer
lastSync [CacheElem]
elems1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
performGC
      forall a. IORef a -> a -> IO ()
writeIORef Cache
refcache (HashTable RealWorld String CacheElem
cache, Integer
t)


  where

  -- delete elems from the cache according with the checking criteria
  filtercache :: Integer
-> h RealWorld String CacheElem -> Integer -> t CacheElem -> IO ()
filtercache Integer
t h RealWorld String CacheElem
cache Integer
lastSync = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CacheElem -> IO ()
filter1
    where
    filter1 :: CacheElem -> IO ()
filter1 (CacheElem Maybe (DBRef a)
Nothing Weak (DBRef a)
_)= forall (m :: * -> *) a. Monad m => a -> m a
return()  --alive because the dbref is being referenced elsewere
    filter1 (CacheElem (Just (DBRef String
key1 TPVar a
_)) Weak (DBRef a)
w) = do
     Maybe (DBRef a)
mr <-  forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
     case Maybe (DBRef a)
mr of
       Maybe (DBRef a)
Nothing ->    forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w
       Just (DBRef String
_  TPVar a
tv) -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
         Status (Elem a)
r <- forall a. TVar a -> STM a
readTVar TPVar a
tv
         case Status (Elem a)
r of
            Exist (Elem a
_ Integer
lastAccess Integer
_ ) ->
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer -> Integer -> Integer -> Bool
check1 Integer
t Integer
lastAccess Integer
lastSync) forall a b. (a -> b) -> a -> b
$ do
                    forall a. IO a -> STM a
unsafeIOToSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert h RealWorld String CacheElem
cache String
key1 forall a b. (a -> b) -> a -> b
$ forall a.
(IResource a, Typeable a) =>
Maybe (DBRef a) -> Weak (DBRef a) -> CacheElem
CacheElem forall a. Maybe a
Nothing Weak (DBRef a)
w
                    forall a. TVar a -> a -> STM ()
writeTVar TPVar a
tv forall a. Status a
NotRead
            Status (Elem a)
_    ->  forall (m :: * -> *) a. Monad m => a -> m a
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 :: Integer -> Integer -> Integer -> Bool
defaultCheck  Integer
now Integer
lastAccess Integer
lastSync
        | Integer
lastAccess forall a. Ord a => a -> a -> Bool
> Integer
halftime = Bool
False
        | Bool
otherwise  = Bool
True

    where
    halftime :: Integer
halftime= Integer
nowforall a. Num a => a -> a -> a
- (Integer
nowforall a. Num a => a -> a -> a
-Integer
lastSync) forall a. Integral a => a -> a -> a
`div` Integer
2

{-# NOINLINE refConditions #-}
refConditions :: IORef (IO (), IO ())
refConditions :: IORef (IO (), IO ())
refConditions= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (forall (m :: * -> *) a. Monad m => a -> m a
return(), forall (m :: * -> *) a. Monad m => a -> m a
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 :: IO () -> IO () -> IO ()
setConditions IO ()
pre IO ()
post= forall a. IORef a -> a -> IO ()
writeIORef IORef (IO (), IO ())
refConditions (IO ()
pre, IO ()
post)

{-# NOINLINE saving #-}
saving :: MVar Bool
saving :: MVar Bool
saving= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar Bool
False

save :: Foldable t => t Filtered -> IO ()
save :: forall (t :: * -> *). Foldable t => t Filtered -> IO ()
save  t Filtered
tosave = do
     (IO ()
pre, IO ()
post) <-  forall a. IORef a -> IO a
readIORef IORef (IO (), IO ())
refConditions
     IO ()
pre    -- !> (concatMap (\(Filtered x) -> keyResource x)tosave)
     forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Filtered a
x) -> forall a. IResource a => a -> IO ()
writeResource a
x) t Filtered
tosave
     IO ()
post


data Filtered= forall a.(IResource a)=> Filtered a


extract :: [(a, CacheElem)] -> Integer -> STM ([Filtered], [CacheElem], Int)
extract :: forall a.
[(a, CacheElem)] -> Integer -> STM ([Filtered], [CacheElem], Int)
extract [(a, CacheElem)]
elems Integer
lastSave= forall {c} {a}.
Num c =>
[Filtered]
-> [CacheElem]
-> c
-> [(a, CacheElem)]
-> STM ([Filtered], [CacheElem], c)
filter1 [] [] (Int
0:: Int)  [(a, CacheElem)]
elems
 where
  filter1 :: [Filtered]
-> [CacheElem]
-> c
-> [(a, CacheElem)]
-> STM ([Filtered], [CacheElem], c)
filter1 [Filtered]
sav [CacheElem]
val c
n []= forall (m :: * -> *) a. Monad m => a -> m a
return ([Filtered]
sav, [CacheElem]
val, c
n)
  filter1 [Filtered]
sav [CacheElem]
val c
n ((a
_, ch :: CacheElem
ch@(CacheElem Maybe (DBRef a)
mybe Weak (DBRef a)
w)):[(a, CacheElem)]
rest)= do
      Maybe (DBRef a)
mr <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (DBRef a)
w
      case Maybe (DBRef a)
mr of
        Maybe (DBRef a)
Nothing -> forall a. IO a -> STM a
unsafeIOToSTM (forall v. Weak v -> IO ()
finalize Weak (DBRef a)
w) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Filtered]
-> [CacheElem]
-> c
-> [(a, CacheElem)]
-> STM ([Filtered], [CacheElem], c)
filter1 [Filtered]
sav [CacheElem]
val c
n [(a, CacheElem)]
rest
        Just (DBRef String
_  TPVar a
tvr)  ->
         let  tofilter :: [CacheElem]
tofilter = case Maybe (DBRef a)
mybe of
                    Just DBRef a
_ -> CacheElem
chforall a. a -> [a] -> [a]
:[CacheElem]
val
                    Maybe (DBRef a)
Nothing -> [CacheElem]
val
         in do
          Status (Elem a)
r <- forall a. TVar a -> STM a
readTVar TPVar a
tvr
          case Status (Elem a)
r of
            Exist (Elem a
r1 Integer
_ Integer
modTime) ->
                  if Integer
modTime forall a. Ord a => a -> a -> Bool
>= Integer
lastSave
                    then [Filtered]
-> [CacheElem]
-> c
-> [(a, CacheElem)]
-> STM ([Filtered], [CacheElem], c)
filter1 (forall a. IResource a => a -> Filtered
Filtered a
r1forall a. a -> [a] -> [a]
:[Filtered]
sav) [CacheElem]
tofilter (c
nforall a. Num a => a -> a -> a
+c
1) [(a, CacheElem)]
rest
                    else [Filtered]
-> [CacheElem]
-> c
-> [(a, CacheElem)]
-> STM ([Filtered], [CacheElem], c)
filter1 [Filtered]
sav [CacheElem]
tofilter (c
nforall a. Num a => a -> a -> a
+c
1) [(a, CacheElem)]
rest -- !> ("rejected->" ++ keyResource r)

            Status (Elem a)
_ -> [Filtered]
-> [CacheElem]
-> c
-> [(a, CacheElem)]
-> STM ([Filtered], [CacheElem], c)
filter1 [Filtered]
sav [CacheElem]
tofilter (c
nforall a. Num a => a -> a -> a
+c
1) [(a, CacheElem)]
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 :: forall a. IO a -> STM a
safeIOToSTM IO a
req= forall a. IO a -> STM a
unsafeIOToSTM  forall a b. (a -> b) -> a -> b
$ do
  MVar (Either SomeException a)
tv   <- forall a. IO (MVar a)
newEmptyMVar
  ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ (IO a
req  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar  MVar (Either SomeException a)
tv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right)
          forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch`
          (\(SomeException
e :: SomeException) -> forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException a)
tv forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left SomeException
e )
  Either SomeException a
r <- forall a. MVar a -> IO a
takeMVar MVar (Either SomeException a)
tv
  case Either SomeException a
r of
   Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
   Left SomeException
e -> forall a e. Exception e => e -> a
throw SomeException
e