-- | App-level caching backed by Memcached
--
-- Usage:
--
-- 1. Have a Reader-like monad stack over some @App@
-- 2. Set up that @App@ with 'HasMemcachedClient'
-- 3. Give the value to cache a 'Cachable' instance
-- 4. Use 'caching'
--
-- To avoid 'Cachable', see 'cachingAs' and 'cachingAsJSON'.
--
module Freckle.App.Memcached
  ( Cachable(..)
  , caching
  , cachingAs
  , cachingAsJSON

  -- * Re-exports
  , module Freckle.App.Memcached.Client
  , module Freckle.App.Memcached.CacheKey
  , module Freckle.App.Memcached.CacheTTL
  ) where

import Freckle.App.Prelude

import Control.Monad.Logger (MonadLogger, logErrorN)
import Data.Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Freckle.App.Memcached.CacheKey
import Freckle.App.Memcached.CacheTTL
import Freckle.App.Memcached.Client (HasMemcachedClient(..))
import qualified Freckle.App.Memcached.Client as Memcached
import UnliftIO.Exception (Exception(..), handleAny)

class Cachable a where
  toCachable :: a -> ByteString
  fromCachable :: ByteString -> Either String a

instance Cachable ByteString where
  toCachable :: ByteString -> ByteString
toCachable = ByteString -> ByteString
forall a. a -> a
id
  fromCachable :: ByteString -> Either String ByteString
fromCachable = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right

instance Cachable BSL.ByteString where
  toCachable :: ByteString -> ByteString
toCachable = ByteString -> ByteString
BSL.toStrict
  fromCachable :: ByteString -> Either String ByteString
fromCachable = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict

instance Cachable Text where
  toCachable :: Text -> ByteString
toCachable = Text -> ByteString
encodeUtf8
  fromCachable :: ByteString -> Either String Text
fromCachable = Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text)
-> (ByteString -> Text) -> ByteString -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode

data Cached a
  = CacheFound a
  | CacheNotFound
  | CacheError Text

-- | Memoize an action using Memcached and 'Cachable'
caching
  :: ( MonadUnliftIO m
     , MonadLogger m
     , MonadReader env m
     , HasMemcachedClient env
     , Cachable a
     )
  => CacheKey
  -> CacheTTL
  -> m a
  -> m a
caching :: CacheKey -> CacheTTL -> m a -> m a
caching = (ByteString -> Either String a)
-> (a -> ByteString) -> CacheKey -> CacheTTL -> m a -> m a
forall (m :: * -> *) env a.
(MonadUnliftIO m, MonadLogger m, MonadReader env m,
 HasMemcachedClient env) =>
(ByteString -> Either String a)
-> (a -> ByteString) -> CacheKey -> CacheTTL -> m a -> m a
cachingAs ByteString -> Either String a
forall a. Cachable a => ByteString -> Either String a
fromCachable a -> ByteString
forall a. Cachable a => a -> ByteString
toCachable

-- | Like 'caching', but with explicit conversion functions
cachingAs
  :: (MonadUnliftIO m, MonadLogger m, MonadReader env m, HasMemcachedClient env)
  => (ByteString -> Either String a)
  -> (a -> ByteString)
  -> CacheKey
  -> CacheTTL
  -> m a
  -> m a
cachingAs :: (ByteString -> Either String a)
-> (a -> ByteString) -> CacheKey -> CacheTTL -> m a -> m a
cachingAs ByteString -> Either String a
from a -> ByteString
to CacheKey
key CacheTTL
ttl m a
f = do
  Cached a
result <-
    (Maybe ByteString -> Cached a)
-> m (Maybe ByteString) -> m (Cached a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cached a
-> (ByteString -> Cached a) -> Maybe ByteString -> Cached a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Cached a
forall a. Cached a
CacheNotFound ((String -> Cached a)
-> (a -> Cached a) -> Either String a -> Cached a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Cached a
forall a. Text -> Cached a
CacheError (Text -> Cached a) -> (String -> Text) -> String -> Cached a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) a -> Cached a
forall a. a -> Cached a
CacheFound (Either String a -> Cached a)
-> (ByteString -> Either String a) -> ByteString -> Cached a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
from))
    (m (Maybe ByteString) -> m (Cached a))
-> m (Maybe ByteString) -> m (Cached a)
forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Text -> m (Maybe ByteString) -> m (Maybe ByteString)
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
a -> Text -> m a -> m a
handleCachingError Maybe ByteString
forall a. Maybe a
Nothing Text
"getting"
    (m (Maybe ByteString) -> m (Maybe ByteString))
-> m (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ CacheKey -> m (Maybe ByteString)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasMemcachedClient env) =>
CacheKey -> m (Maybe ByteString)
Memcached.get CacheKey
key

  case Cached a
result of
    CacheFound a
a -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Cached a
CacheNotFound -> m a
store
    CacheError Text
e -> do
      Text -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logCachingError Text
"deserializing" Text
e
      m a
store
 where
  store :: m a
store = do
    a
a <- m a
f
    a
a a -> m () -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ () -> Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
a -> Text -> m a -> m a
handleCachingError () Text
"setting" (CacheKey -> ByteString -> CacheTTL -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasMemcachedClient env) =>
CacheKey -> ByteString -> CacheTTL -> m ()
Memcached.set CacheKey
key (a -> ByteString
to a
a) CacheTTL
ttl)

-- | Like 'caching', but de/serializing the value as JSON
cachingAsJSON
  :: ( MonadUnliftIO m
     , MonadLogger m
     , MonadReader env m
     , HasMemcachedClient env
     , FromJSON a
     , ToJSON a
     )
  => CacheKey
  -> CacheTTL
  -> m a
  -> m a
cachingAsJSON :: CacheKey -> CacheTTL -> m a -> m a
cachingAsJSON = (ByteString -> Either String a)
-> (a -> ByteString) -> CacheKey -> CacheTTL -> m a -> m a
forall (m :: * -> *) env a.
(MonadUnliftIO m, MonadLogger m, MonadReader env m,
 HasMemcachedClient env) =>
(ByteString -> Either String a)
-> (a -> ByteString) -> CacheKey -> CacheTTL -> m a -> m a
cachingAs ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict a -> ByteString
forall a. ToJSON a => a -> ByteString
encodeStrict

handleCachingError
  :: (MonadUnliftIO m, MonadLogger m) => a -> Text -> m a -> m a
handleCachingError :: a -> Text -> m a -> m a
handleCachingError a
value Text
action = (SomeException -> m a) -> m a -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny ((SomeException -> m a) -> m a -> m a)
-> (SomeException -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> do
  Text -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logCachingError Text
action (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex
  a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

logCachingError :: MonadLogger m => Text -> Text -> m ()
logCachingError :: Text -> Text -> m ()
logCachingError Text
action Text
message =
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"[Caching] error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
action Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
message

encodeStrict :: ToJSON a => a -> ByteString
encodeStrict :: a -> ByteString
encodeStrict = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode