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

import Prelude

import Control.Lens (Lens', view, _1)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader)
import Data.Functor (void)
import Data.HashMap.Strict qualified as HashMap
import Database.Memcache.Client qualified as Memcache
import Database.Memcache.Types (Value, Version)
import Freckle.App.Memcached.CacheKey
import Freckle.App.Memcached.CacheTTL
import Freckle.App.Memcached.Servers
import Freckle.App.OpenTelemetry (byteStringToAttribute)
import OpenTelemetry.Trace (SpanKind (..), defaultSpanArguments)
import OpenTelemetry.Trace qualified as Trace
import OpenTelemetry.Trace.Monad
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (finally)

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

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
$ ((Value, Flags, Version) -> Value)
-> Maybe (Value, Flags, Version) -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) (Maybe (Value, Flags, Version) -> Maybe Value)
-> IO (Maybe (Value, Flags, Version)) -> IO (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
defaultSpanArguments
        { Trace.kind = Client
        , Trace.attributes =
            HashMap.fromList
              [ ("service.name", "memcached")
              , ("key", Trace.toAttribute 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
defaultSpanArguments
        { Trace.kind = Client
        , Trace.attributes =
            HashMap.fromList
              [ ("service.name", "memcached")
              , ("key", Trace.toAttribute k)
              , ("value", byteStringToAttribute v)
              , ("expiration", Trace.toAttribute expiration)
              ]
        }

-- | Delete a key
delete
  :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env)
  => CacheKey
  -> m ()
delete :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> m ()
delete CacheKey
k = 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 Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Client -> Value -> Version -> IO Bool
Memcache.delete Client
mc (CacheKey -> Value
fromCacheKey CacheKey
k) Version
bypassCAS
  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.delete"
      SpanArguments
defaultSpanArguments
        { Trace.kind = Client
        , Trace.attributes = HashMap.fromList [("key", Trace.toAttribute k)]
        }

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

-- | The sentinal version @0@ means to not perform CAS checking
bypassCAS :: Version
bypassCAS :: Version
bypassCAS = Version
0