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 = forall a. a -> a
id

instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where
  memcachedClientL :: Lens' (HandlerData child site) MemcachedClient
memcachedClientL = forall child site.
Lens' (HandlerData child site) (RunHandlerEnv child site)
envL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall child site. Lens' (RunHandlerEnv child site) site
siteL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. HasMemcachedClient env => Lens' env 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
  [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MemcachedClient
memcachedClientDisabled
  [ServerSpec]
specs -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Client -> MemcachedClient
MemcachedClient forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ServerSpec] -> Options -> IO Client
Memcache.newClient [ServerSpec]
specs 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 <- forall (m :: * -> *).
MonadIO m =>
MemcachedServers -> m MemcachedClient
newMemcachedClient MemcachedServers
servers
  MemcachedClient -> m a
f MemcachedClient
c forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` 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 forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(MonadReader env m, HasMemcachedClient env) =>
(MemcachedClient -> m a) -> m a
with forall a b. (a -> b) -> a -> b
$ \case
  MemcachedClient Client
mc -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s t a b. Field1 s t a b => Lens s t a b
_1 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
 where
  traced :: m (Maybe Value) -> m (Maybe Value)
traced =
    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 = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Text
"key", 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 forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(MonadReader env m, HasMemcachedClient env) =>
(MemcachedClient -> m a) -> m a
with forall a b. (a -> b) -> a -> b
$ \case
  MemcachedClient Client
mc ->
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$
          CacheTTL -> Flags
fromCacheTTL
            CacheTTL
expiration
  MemcachedClient
MemcachedClientDisabled -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  traced :: m () -> m ()
traced =
    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 =
            forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
              [ (Text
"key", forall a. ToAttribute a => a -> Attribute
Trace.toAttribute CacheKey
k)
              , (Text
"value", Value -> Attribute
byteStringToAttribute Value
v)
              , (Text
"expiration", 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 -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Client -> IO ()
Memcache.quit Client
mc
  MemcachedClient
MemcachedClientDisabled -> 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasMemcachedClient env => Lens' env MemcachedClient
memcachedClientL
  MemcachedClient -> m a
f MemcachedClient
c