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
:: (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