module Freckle.App.Memcached.Client
  ( MemcachedClient (..)
  , newMemcachedClient
  , withMemcachedClient
  , memcachedClientDisabled
  , HasMemcachedClient (..)
  , get
  , set
  ) where

import Freckle.App.Prelude

import Control.Lens (Lens', view, _1)
import qualified Data.HashMap.Strict as HashMap
import qualified Database.Memcache.Client as Memcache
import Database.Memcache.Types (Value)
import Freckle.App.Memcached.CacheKey
import Freckle.App.Memcached.CacheTTL
import Freckle.App.Memcached.Servers
import Freckle.App.OpenTelemetry
import qualified OpenTelemetry.Trace as Trace
import UnliftIO.Exception (finally)
import Yesod.Core.Lens
import Yesod.Core.Types (HandlerData)

data MemcachedClient
  = MemcachedClient Memcache.Client
  | MemcachedClientDisabled

class HasMemcachedClient env where
  memcachedClientL :: Lens' env MemcachedClient

instance HasMemcachedClient MemcachedClient where
  memcachedClientL :: Lens' MemcachedClient MemcachedClient
memcachedClientL = (MemcachedClient -> f MemcachedClient)
-> MemcachedClient -> f MemcachedClient
forall a. a -> a
id

instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where
  memcachedClientL :: Lens' (HandlerData child site) MemcachedClient
memcachedClientL = (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
forall child site (f :: * -> *).
Functor f =>
(RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
envL ((RunHandlerEnv child site -> f (RunHandlerEnv child site))
 -> HandlerData child site -> f (HandlerData child site))
-> ((MemcachedClient -> f MemcachedClient)
    -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> (MemcachedClient -> f MemcachedClient)
-> HandlerData child site
-> f (HandlerData child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
forall child site (f :: * -> *).
Functor f =>
(site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
siteL ((site -> f site)
 -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> ((MemcachedClient -> f MemcachedClient) -> site -> f site)
-> (MemcachedClient -> f MemcachedClient)
-> RunHandlerEnv child site
-> f (RunHandlerEnv child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemcachedClient -> f MemcachedClient) -> site -> f site
forall env. HasMemcachedClient env => Lens' env MemcachedClient
Lens' site MemcachedClient
memcachedClientL

newMemcachedClient :: MonadIO m => MemcachedServers -> m MemcachedClient
newMemcachedClient :: forall (m :: * -> *).
MonadIO m =>
MemcachedServers -> m MemcachedClient
newMemcachedClient MemcachedServers
servers = case MemcachedServers -> [ServerSpec]
toServerSpecs MemcachedServers
servers of
  [] -> MemcachedClient -> m MemcachedClient
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MemcachedClient
memcachedClientDisabled
  [ServerSpec]
specs -> IO MemcachedClient -> m MemcachedClient
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MemcachedClient -> m MemcachedClient)
-> IO MemcachedClient -> m MemcachedClient
forall a b. (a -> b) -> a -> b
$ Client -> MemcachedClient
MemcachedClient (Client -> MemcachedClient) -> IO Client -> IO MemcachedClient
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ServerSpec] -> Options -> IO Client
Memcache.newClient [ServerSpec]
specs Options
forall a. Default a => a
Memcache.def

withMemcachedClient
  :: MonadUnliftIO m => MemcachedServers -> (MemcachedClient -> m a) -> m a
withMemcachedClient :: forall (m :: * -> *) a.
MonadUnliftIO m =>
MemcachedServers -> (MemcachedClient -> m a) -> m a
withMemcachedClient MemcachedServers
servers MemcachedClient -> m a
f = do
  MemcachedClient
c <- MemcachedServers -> m MemcachedClient
forall (m :: * -> *).
MonadIO m =>
MemcachedServers -> m MemcachedClient
newMemcachedClient MemcachedServers
servers
  MemcachedClient -> m a
f MemcachedClient
c m a -> m () -> m a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` MemcachedClient -> m ()
forall (m :: * -> *). MonadIO m => MemcachedClient -> m ()
quitClient MemcachedClient
c

memcachedClientDisabled :: MemcachedClient
memcachedClientDisabled :: MemcachedClient
memcachedClientDisabled = MemcachedClient
MemcachedClientDisabled

get
  :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env)
  => CacheKey
  -> m (Maybe Value)
get :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> m (Maybe Value)
get CacheKey
k = m (Maybe Value) -> m (Maybe Value)
traced (m (Maybe Value) -> m (Maybe Value))
-> m (Maybe Value) -> m (Maybe Value)
forall a b. (a -> b) -> a -> b
$ (MemcachedClient -> m (Maybe Value)) -> m (Maybe Value)
forall env (m :: * -> *) a.
(MonadReader env m, HasMemcachedClient env) =>
(MemcachedClient -> m a) -> m a
with ((MemcachedClient -> m (Maybe Value)) -> m (Maybe Value))
-> (MemcachedClient -> m (Maybe Value)) -> m (Maybe Value)
forall a b. (a -> b) -> a -> b
$ \case
  MemcachedClient Client
mc -> IO (Maybe Value) -> m (Maybe Value)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Value) -> m (Maybe Value))
-> IO (Maybe Value) -> m (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Getting Value (Value, Flags, Version) Value
-> (Value, Flags, Version) -> Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Value (Value, Flags, Version) Value
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Value, Flags, Version) (Value, Flags, Version) Value Value
_1 ((Value, Flags, Version) -> Value)
-> IO (Maybe (Value, Flags, Version)) -> IO (Maybe Value)
forall (c :: * -> *) (d :: * -> *) a b.
(Functor c, Functor d) =>
(a -> b) -> c (d a) -> c (d b)
<$$> Client -> Value -> IO (Maybe (Value, Flags, Version))
Memcache.get Client
mc (CacheKey -> Value
fromCacheKey CacheKey
k)
  MemcachedClient
MemcachedClientDisabled -> Maybe Value -> m (Maybe Value)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
 where
  traced :: m (Maybe Value) -> m (Maybe Value)
traced =
    Text -> SpanArguments -> m (Maybe Value) -> m (Maybe Value)
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadTracer m, HasCallStack) =>
Text -> SpanArguments -> m a -> m a
inSpan
      Text
"cache.get"
      SpanArguments
clientSpanArguments
        { attributes :: HashMap Text Attribute
Trace.attributes = [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Text
"key", CacheKey -> Attribute
forall a. ToAttribute a => a -> Attribute
Trace.toAttribute CacheKey
k)]
        }

-- | Set a value to expire in the given seconds
--
-- Pass @0@ to set a value that never expires.
set
  :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env)
  => CacheKey
  -> Value
  -> CacheTTL
  -> m ()
set :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> Value -> CacheTTL -> m ()
set CacheKey
k Value
v CacheTTL
expiration = m () -> m ()
traced (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (MemcachedClient -> m ()) -> m ()
forall env (m :: * -> *) a.
(MonadReader env m, HasMemcachedClient env) =>
(MemcachedClient -> m a) -> m a
with ((MemcachedClient -> m ()) -> m ())
-> (MemcachedClient -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
  MemcachedClient Client
mc ->
    m Version -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Version -> m ()) -> m Version -> m ()
forall a b. (a -> b) -> a -> b
$
      IO Version -> m Version
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Version -> m Version) -> IO Version -> m Version
forall a b. (a -> b) -> a -> b
$
        Client -> Value -> Value -> Flags -> Flags -> IO Version
Memcache.set Client
mc (CacheKey -> Value
fromCacheKey CacheKey
k) Value
v Flags
0 (Flags -> IO Version) -> Flags -> IO Version
forall a b. (a -> b) -> a -> b
$
          CacheTTL -> Flags
fromCacheTTL
            CacheTTL
expiration
  MemcachedClient
MemcachedClientDisabled -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  traced :: m () -> m ()
traced =
    Text -> SpanArguments -> m () -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadTracer m, HasCallStack) =>
Text -> SpanArguments -> m a -> m a
inSpan
      Text
"cache.set"
      SpanArguments
clientSpanArguments
        { attributes :: HashMap Text Attribute
Trace.attributes =
            [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
              [ (Text
"key", CacheKey -> Attribute
forall a. ToAttribute a => a -> Attribute
Trace.toAttribute CacheKey
k)
              , (Text
"value", Value -> Attribute
byteStringToAttribute Value
v)
              , (Text
"expiration", CacheTTL -> Attribute
forall a. ToAttribute a => a -> Attribute
Trace.toAttribute CacheTTL
expiration)
              ]
        }

quitClient :: MonadIO m => MemcachedClient -> m ()
quitClient :: forall (m :: * -> *). MonadIO m => MemcachedClient -> m ()
quitClient = \case
  MemcachedClient Client
mc -> m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Client -> IO ()
Memcache.quit Client
mc
  MemcachedClient
MemcachedClientDisabled -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

with
  :: (MonadReader env m, HasMemcachedClient env)
  => (MemcachedClient -> m a)
  -> m a
with :: forall env (m :: * -> *) a.
(MonadReader env m, HasMemcachedClient env) =>
(MemcachedClient -> m a) -> m a
with MemcachedClient -> m a
f = do
  MemcachedClient
c <- Getting MemcachedClient env MemcachedClient -> m MemcachedClient
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting MemcachedClient env MemcachedClient
forall env. HasMemcachedClient env => Lens' env MemcachedClient
Lens' env MemcachedClient
memcachedClientL
  MemcachedClient -> m a
f MemcachedClient
c