module Freckle.App.Memcached.Client
( MemcachedClient
, newMemcachedClient
, memcachedClientDisabled
, HasMemcachedClient(..)
, get
, set
) where
import Freckle.App.Prelude
import Control.Lens (Lens', _1, view)
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 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 :: (MemcachedClient -> f MemcachedClient)
-> MemcachedClient -> f MemcachedClient
memcachedClientL = (MemcachedClient -> f MemcachedClient)
-> MemcachedClient -> f MemcachedClient
forall a. a -> a
id
instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where
memcachedClientL :: (MemcachedClient -> f MemcachedClient)
-> HandlerData child site -> f (HandlerData child site)
memcachedClientL = (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
forall child site.
Lens' (HandlerData child site) (RunHandlerEnv 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. Lens' (RunHandlerEnv child site) 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
memcachedClientL
newMemcachedClient :: MonadIO m => MemcachedServers -> m MemcachedClient
newMemcachedClient :: MemcachedServers -> m MemcachedClient
newMemcachedClient MemcachedServers
servers = case MemcachedServers -> [ServerSpec]
toServerSpecs MemcachedServers
servers of
[] -> MemcachedClient -> m MemcachedClient
forall (f :: * -> *) a. Applicative f => a -> f a
pure MemcachedClient
memcachedClientDisabled
[ServerSpec]
specs -> IO MemcachedClient -> m MemcachedClient
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
memcachedClientDisabled :: MemcachedClient
memcachedClientDisabled :: MemcachedClient
memcachedClientDisabled = MemcachedClient
MemcachedClientDisabled
get
:: (MonadIO m, MonadReader env m, HasMemcachedClient env)
=> CacheKey
-> m (Maybe Value)
get :: CacheKey -> m (Maybe Value)
get CacheKey
k = (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 (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
_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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
set
:: (MonadIO m, MonadReader env m, HasMemcachedClient env)
=> CacheKey
-> Value
-> CacheTTL
-> m ()
set :: CacheKey -> Value -> CacheTTL -> m ()
set CacheKey
k Value
v CacheTTL
expiration = (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
with
:: (MonadReader env m, HasMemcachedClient env)
=> (MemcachedClient -> m a)
-> m a
with :: (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
memcachedClientL
MemcachedClient -> m a
f MemcachedClient
c