-- | LRU cache to speedup fetching of the route handler
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)

-- | Cache config
data CacheConfig = CacheConfig
  { CacheConfig -> Int
size :: Int
  -- ^ how many items are allowed in the cache
  , CacheConfig -> CacheKey -> Bool
cacheFilter :: CacheKey -> Bool
  -- ^ which route to cache
  }

-- | Route key identidfies the single item for caching
data CacheKey = CacheKey
  { CacheKey -> ByteString
inputType :: ByteString
  -- ^ value of "Content-Type" header
  , CacheKey -> ByteString
outputType :: ByteString
  -- ^ value of "Accept" header
  , CacheKey -> ByteString
method :: Method
  -- ^ http method
  , CacheKey -> [Text]
path :: [Text]
  -- ^ path to route (includes inlined captures)
  }
  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)

-- | Cache value
data CacheValue m = CacheValue
  { forall (m :: * -> *). CacheValue m -> CaptureMap
captures :: CaptureMap
  -- ^ extracted capture map from the path
  , forall (m :: * -> *). CacheValue m -> Route m
route :: Route m
  -- ^ route handler
  }

-- | Route cache
data RouteCache m = RouteCache
  { forall (m :: * -> *). RouteCache m -> CacheKey -> Bool
cacheFilter :: CacheKey -> Bool
  -- ^ which route to cache (if True the route is cached)
  , forall (m :: * -> *).
RouteCache m -> AtomicLRU CacheKey (CacheValue m)
cache :: AtomicLRU CacheKey (CacheValue m)
  -- ^ cache map
  }

-- | Allocates new cache
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))

-- | Caches the function of route finder
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