module Freckle.App.Memcached.Client
  ( MemcachedClient
  , newMemcachedClient
  , withMemcachedClient
  , 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 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
  :: (MonadIO m, MonadReader env m, HasMemcachedClient env)
  => CacheKey
  -> m (Maybe Value)
get :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasMemcachedClient env) =>
CacheKey -> m (Maybe Value)
get CacheKey
k = 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

-- | 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasMemcachedClient env) =>
CacheKey -> Value -> CacheTTL -> m ()
set CacheKey
k Value
v CacheTTL
expiration = 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 ()

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