module Mig.Core.Server.Cache (
CacheConfig (..),
CacheKey (..),
CacheValue (..),
RouteCache (..),
newRouteCache,
withCache,
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.Cache.LRU.IO (AtomicLRU)
import Data.Cache.LRU.IO qualified as Lru
import Data.Text (Text)
import Mig.Core.Api (CaptureMap)
import Mig.Core.Class.Route (Route)
import Network.HTTP.Types.Method (Method)
data CacheConfig = CacheConfig
{ CacheConfig -> Int
size :: Int
, CacheConfig -> CacheKey -> Bool
cacheFilter :: CacheKey -> Bool
}
data CacheKey = CacheKey
{ CacheKey -> ByteString
inputType :: ByteString
, CacheKey -> ByteString
outputType :: ByteString
, CacheKey -> ByteString
method :: Method
, CacheKey -> [Text]
path :: [Text]
}
deriving (Int -> CacheKey -> ShowS
[CacheKey] -> ShowS
CacheKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheKey] -> ShowS
$cshowList :: [CacheKey] -> ShowS
show :: CacheKey -> String
$cshow :: CacheKey -> String
showsPrec :: Int -> CacheKey -> ShowS
$cshowsPrec :: Int -> CacheKey -> ShowS
Show, CacheKey -> CacheKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c== :: CacheKey -> CacheKey -> Bool
Eq, Eq CacheKey
CacheKey -> CacheKey -> Bool
CacheKey -> CacheKey -> Ordering
CacheKey -> CacheKey -> CacheKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CacheKey -> CacheKey -> CacheKey
$cmin :: CacheKey -> CacheKey -> CacheKey
max :: CacheKey -> CacheKey -> CacheKey
$cmax :: CacheKey -> CacheKey -> CacheKey
>= :: CacheKey -> CacheKey -> Bool
$c>= :: CacheKey -> CacheKey -> Bool
> :: CacheKey -> CacheKey -> Bool
$c> :: CacheKey -> CacheKey -> Bool
<= :: CacheKey -> CacheKey -> Bool
$c<= :: CacheKey -> CacheKey -> Bool
< :: CacheKey -> CacheKey -> Bool
$c< :: CacheKey -> CacheKey -> Bool
compare :: CacheKey -> CacheKey -> Ordering
$ccompare :: CacheKey -> CacheKey -> Ordering
Ord)
data CacheValue m = CacheValue
{ forall (m :: * -> *). CacheValue m -> CaptureMap
captures :: CaptureMap
, forall (m :: * -> *). CacheValue m -> Route m
route :: Route m
}
data RouteCache m = RouteCache
{ forall (m :: * -> *). RouteCache m -> CacheKey -> Bool
cacheFilter :: CacheKey -> Bool
, forall (m :: * -> *).
RouteCache m -> AtomicLRU CacheKey (CacheValue m)
cache :: AtomicLRU CacheKey (CacheValue m)
}
newRouteCache :: CacheConfig -> IO (RouteCache m)
newRouteCache :: forall (m :: * -> *). CacheConfig -> IO (RouteCache m)
newRouteCache CacheConfig
config =
forall (m :: * -> *).
(CacheKey -> Bool)
-> AtomicLRU CacheKey (CacheValue m) -> RouteCache m
RouteCache CacheConfig
config.cacheFilter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key val. Ord key => Maybe Integer -> IO (AtomicLRU key val)
Lru.newAtomicLRU (forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral CacheConfig
config.size))
withCache :: RouteCache m -> (CacheKey -> Maybe (CacheValue m)) -> CacheKey -> IO (Maybe (CacheValue m))
withCache :: forall (m :: * -> *).
RouteCache m
-> (CacheKey -> Maybe (CacheValue m))
-> CacheKey
-> IO (Maybe (CacheValue m))
withCache (RouteCache CacheKey -> Bool
cacheFilter AtomicLRU CacheKey (CacheValue m)
cache) CacheKey -> Maybe (CacheValue m)
f CacheKey
key = do
Maybe (CacheValue m)
mCacheResult <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.lookup CacheKey
key AtomicLRU CacheKey (CacheValue m)
cache
case Maybe (CacheValue m)
mCacheResult of
Just CacheValue m
result -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just CacheValue m
result)
Maybe (CacheValue m)
Nothing -> do
case CacheKey -> Maybe (CacheValue m)
f CacheKey
key of
Just CacheValue m
result -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CacheKey -> Bool
cacheFilter CacheKey
key) forall a b. (a -> b) -> a -> b
$ forall key val. Ord key => key -> val -> AtomicLRU key val -> IO ()
Lru.insert CacheKey
key CacheValue m
result AtomicLRU CacheKey (CacheValue m)
cache
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just CacheValue m
result)
Maybe (CacheValue m)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing