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 a value to expire in the given seconds
--
-- Pass @0@ to set a value that never expires.
--
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