Caching.hs

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Module supporting the caching of a service.
module Glue.Caching
  ( cacheWithBasic
  , cacheWithMulti
  ) where

import           Data.Hashable       (Hashable)
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet        as S
import           Glue.Types

-- | Caching of a 'BasicService' instance, that defers to external functions for the actual caching.
-- Note: Values within @m@ will be lost for calls that hit the cache.
cacheWithBasic
  :: Monad m
  => (a -> m (Maybe b))
  -- ^ Cache lookup function, used before potentially invoking the fallback service.
  -> (a -> b -> m ())
  -- ^ Cache write function, used after invoking the fallback service to populate the cache.
  -> BasicService m a b
  -- ^ The service to cache.
  -> BasicService m a b
cacheWithBasic lookupWith insertWith service =
  let fallback request = do
        result <- service request
        insertWith request result
        pure result
      cachedService request = do
        fromCache <- lookupWith request
        maybe (fallback request) pure fromCache
  in  cachedService

-- | Caching of a 'MultiGetService' instance, that defers to external functions for the actual caching.
-- Partial responses will result in partial fallback calls that get just the missing keys.
-- Values within @m@ will be lost for calls that hit the cache.
cacheWithMulti
  :: (Monad m, Hashable a)
  => (MultiGetRequest a -> m (MultiGetResponse a b))
  -- ^ Cache lookup function, used before potentially invoking the fallback service.
  -> (MultiGetResponse a b -> m ())
  -- ^ Cache write function, used after invoking the fallback service to populate the cache.
  -> MultiGetService m a b
  -- ^ The service to cache.
  -> MultiGetService m a b
cacheWithMulti lookupWith insertWith service =
  let fallback request = do
        result <- service request
        insertWith result
        pure result
      cachedService request = do
        fromCache <- lookupWith request
        let uncachedKeys = S.difference request (S.fromList $ M.keys fromCache)
        if S.null uncachedKeys
          then pure fromCache
          else M.union fromCache <$> fallback uncachedKeys
  in  cachedService