{-# LANGUAGE RecursiveDo #-}
-- | Caching based on the GHC heap object properties and  relies on lazyness implementation
-- in the GHC RTS. This approach does it's best effort for avoiding the duplicated work, 
-- however it the pathological cases it's possible that two theads will run the computation
-- on the same input concurrently. We have not observed this case in practice, but in the
-- case if you need strict guarantees on this property you should use "System.Cache.Impl.MVar"
-- instead.
--
-- This is battle-tested implementation. That fits all the properties that are required by the
-- interface.
--
module System.Cache.Impl.Ghc
  ( new
  ) where

import Control.Exception
import Data.Hashable
import Data.HashPSQ as PSQ
import Data.IORef
import Data.Tuple
import Control.Monad
import System.Clock.Seconds

import System.Cache.Internal.Interface

-- | We need our internal values to be even more lazy, in order
-- to prevent early evaluation and deadlock.
data Lazy a = Lazy { Lazy a -> a
getLazy :: a}

-- | Creates new cache Handle. Keeps priotity queue from @psqueues@ package inside.
--
-- Properties:
--
--  * if multiple threads are running an IO action with the same input
--    concurrently then only one (with the best effort) will run, all
--    the rest will wait for that action and will either return a value,
--    or throw an exception depending on the the result of the first one
--  * storage is cleared only during access, it will remove redundant work
--    but may lead to the situation when cached values are stored in memory
--    for a longer period that it was expected
--  * psqueue structure uses both 'Hashable' and 'Ord' constraints and is
--    not vulnerable to the hash collision attacks.
--
new
  :: (Show a, Hashable a, Ord a)
  => Config
  -> IO (Handle a b)
new :: Config -> IO (Handle a b)
new Config {Seconds
Clock
configClock :: Config -> Clock
configLongestAge :: Config -> Seconds
configClock :: Clock
configLongestAge :: Seconds
..} = do
  IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
ref <- HashPSQ a Seconds (Lazy (Either SomeException b))
-> IO (IORef (HashPSQ a Seconds (Lazy (Either SomeException b))))
forall a. a -> IO (IORef a)
newIORef HashPSQ a Seconds (Lazy (Either SomeException b))
forall k p v. HashPSQ k p v
PSQ.empty
  Handle a b -> IO (Handle a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handle a b -> IO (Handle a b)) -> Handle a b -> IO (Handle a b)
forall a b. (a -> b) -> a -> b
$ Handle :: forall a b.
(Seconds -> a -> (a -> IO b) -> IO b)
-> (a -> IO ()) -> IO Seconds -> Handle a b
Handle
    { requestOrInternal :: Seconds -> a -> (a -> IO b) -> IO b
requestOrInternal = \Seconds
tm a
k a -> IO b
f -> mdo
      Maybe (Lazy (Either SomeException b))
mbox <-
        IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)),
        Maybe (Lazy (Either SomeException b))))
-> IO (Maybe (Lazy (Either SomeException b)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
ref
        ((HashPSQ a Seconds (Lazy (Either SomeException b))
  -> (HashPSQ a Seconds (Lazy (Either SomeException b)),
      Maybe (Lazy (Either SomeException b))))
 -> IO (Maybe (Lazy (Either SomeException b))))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)),
        Maybe (Lazy (Either SomeException b))))
-> IO (Maybe (Lazy (Either SomeException b)))
forall a b. (a -> b) -> a -> b
$ (Maybe (Lazy (Either SomeException b)),
 HashPSQ a Seconds (Lazy (Either SomeException b)))
-> (HashPSQ a Seconds (Lazy (Either SomeException b)),
    Maybe (Lazy (Either SomeException b)))
forall a b. (a, b) -> (b, a)
swap
        ((Maybe (Lazy (Either SomeException b)),
  HashPSQ a Seconds (Lazy (Either SomeException b)))
 -> (HashPSQ a Seconds (Lazy (Either SomeException b)),
     Maybe (Lazy (Either SomeException b))))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (Maybe (Lazy (Either SomeException b)),
        HashPSQ a Seconds (Lazy (Either SomeException b))))
-> HashPSQ a Seconds (Lazy (Either SomeException b))
-> (HashPSQ a Seconds (Lazy (Either SomeException b)),
    Maybe (Lazy (Either SomeException b)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Seconds, Lazy (Either SomeException b))
 -> (Maybe (Lazy (Either SomeException b)),
     Maybe (Seconds, Lazy (Either SomeException b))))
-> a
-> HashPSQ a Seconds (Lazy (Either SomeException b))
-> (Maybe (Lazy (Either SomeException b)),
    HashPSQ a Seconds (Lazy (Either SomeException b)))
forall k p v b.
(Hashable k, Ord k, Ord p) =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> HashPSQ k p v -> (b, HashPSQ k p v)
PSQ.alter
            (\case
              Just (Seconds
p, ~Lazy (Either SomeException b)
v) | Seconds
p Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
>= Seconds -> Seconds -> Seconds
diffTimeSpec Seconds
tm Seconds
configLongestAge ->
                (Lazy (Either SomeException b)
-> Maybe (Lazy (Either SomeException b))
forall a. a -> Maybe a
Just Lazy (Either SomeException b)
v, (Seconds, Lazy (Either SomeException b))
-> Maybe (Seconds, Lazy (Either SomeException b))
forall a. a -> Maybe a
Just (Seconds
p, Lazy (Either SomeException b)
v))
              Maybe (Seconds, Lazy (Either SomeException b))
_ -> (Maybe (Lazy (Either SomeException b))
forall a. Maybe a
Nothing, (Seconds, Lazy (Either SomeException b))
-> Maybe (Seconds, Lazy (Either SomeException b))
forall a. a -> Maybe a
Just (Seconds
tm, Either SomeException b -> Lazy (Either SomeException b)
forall a. a -> Lazy a
Lazy Either SomeException b
eresult))
            )
            a
k
      Either SomeException b
eresult <- IO b -> IO (Either SomeException b)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO b -> IO (Either SomeException b))
-> IO b -> IO (Either SomeException b)
forall a b. (a -> b) -> a -> b
$ IO b
-> (Lazy (Either SomeException b) -> IO b)
-> Maybe (Lazy (Either SomeException b))
-> IO b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (a -> IO b
f a
k)
        (\Lazy (Either SomeException b)
r -> do
          Either SomeException b -> IO (Either SomeException b)
forall a. a -> IO a
evaluate (Lazy (Either SomeException b) -> Either SomeException b
forall a. Lazy a -> a
getLazy Lazy (Either SomeException b)
r) IO (Either SomeException b)
-> (Either SomeException b -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left SomeException
s -> SomeException -> IO b
forall e a. Exception e => e -> IO a
throwIO SomeException
s
            Right b
x -> b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
        )
        Maybe (Lazy (Either SomeException b))
mbox
      b
result <- case Either SomeException b
eresult of
        Left (SomeException
s::SomeException) -> do
          IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
ref ((HashPSQ a Seconds (Lazy (Either SomeException b))
  -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
 -> IO ())
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashPSQ a Seconds (Lazy (Either SomeException b))
v -> (a
-> HashPSQ a Seconds (Lazy (Either SomeException b))
-> HashPSQ a Seconds (Lazy (Either SomeException b))
forall k p v.
(Hashable k, Ord k, Ord p) =>
k -> HashPSQ k p v -> HashPSQ k p v
PSQ.delete a
k HashPSQ a Seconds (Lazy (Either SomeException b))
v,  ())
          SomeException -> IO b
forall e a. Exception e => e -> IO a
throwIO SomeException
s
        Right b
x -> b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
      IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
ref ((HashPSQ a Seconds (Lazy (Either SomeException b))
  -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
 -> IO ())
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ ((), HashPSQ a Seconds (Lazy (Either SomeException b)))
-> (HashPSQ a Seconds (Lazy (Either SomeException b)), ())
forall a b. (a, b) -> (b, a)
swap (((), HashPSQ a Seconds (Lazy (Either SomeException b)))
 -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> ((), HashPSQ a Seconds (Lazy (Either SomeException b))))
-> HashPSQ a Seconds (Lazy (Either SomeException b))
-> (HashPSQ a Seconds (Lazy (Either SomeException b)), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (a, Seconds, Lazy (Either SomeException b))
 -> ((), Maybe (a, Seconds, Lazy (Either SomeException b))))
-> HashPSQ a Seconds (Lazy (Either SomeException b))
-> ((), HashPSQ a Seconds (Lazy (Either SomeException b)))
forall k p v b.
(Hashable k, Ord k, Ord p) =>
(Maybe (k, p, v) -> (b, Maybe (k, p, v)))
-> HashPSQ k p v -> (b, HashPSQ k p v)
PSQ.alterMin
        (\case
          Maybe (a, Seconds, Lazy (Either SomeException b))
Nothing -> ((), Maybe (a, Seconds, Lazy (Either SomeException b))
forall a. Maybe a
Nothing)
          Just (a
kk, Seconds
p, Lazy (Either SomeException b)
v)
            | Seconds
p Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
< Seconds -> Seconds -> Seconds
diffTimeSpec Seconds
tm Seconds
configLongestAge -> ((), Maybe (a, Seconds, Lazy (Either SomeException b))
forall a. Maybe a
Nothing)
            | Bool
otherwise -> ((), (a, Seconds, Lazy (Either SomeException b))
-> Maybe (a, Seconds, Lazy (Either SomeException b))
forall a. a -> Maybe a
Just (a
kk, Seconds
p, Lazy (Either SomeException b)
v))
        )
      b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
result
    , remove :: a -> IO ()
remove = \a
k -> do
       IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashPSQ a Seconds (Lazy (Either SomeException b)))
ref ((HashPSQ a Seconds (Lazy (Either SomeException b))
  -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
 -> IO ())
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ ((), HashPSQ a Seconds (Lazy (Either SomeException b)))
-> (HashPSQ a Seconds (Lazy (Either SomeException b)), ())
forall a b. (a, b) -> (b, a)
swap (((), HashPSQ a Seconds (Lazy (Either SomeException b)))
 -> (HashPSQ a Seconds (Lazy (Either SomeException b)), ()))
-> (HashPSQ a Seconds (Lazy (Either SomeException b))
    -> ((), HashPSQ a Seconds (Lazy (Either SomeException b))))
-> HashPSQ a Seconds (Lazy (Either SomeException b))
-> (HashPSQ a Seconds (Lazy (Either SomeException b)), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Seconds, Lazy (Either SomeException b))
 -> ((), Maybe (Seconds, Lazy (Either SomeException b))))
-> a
-> HashPSQ a Seconds (Lazy (Either SomeException b))
-> ((), HashPSQ a Seconds (Lazy (Either SomeException b)))
forall k p v b.
(Hashable k, Ord k, Ord p) =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> HashPSQ k p v -> (b, HashPSQ k p v)
PSQ.alter (((), Maybe (Seconds, Lazy (Either SomeException b)))
-> Maybe (Seconds, Lazy (Either SomeException b))
-> ((), Maybe (Seconds, Lazy (Either SomeException b)))
forall a b. a -> b -> a
const ((), Maybe (Seconds, Lazy (Either SomeException b))
forall a. Maybe a
Nothing)) a
k
    , getClockTime :: IO Seconds
getClockTime = Clock -> IO Seconds
getTime Clock
configClock
    }