-- | 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
  , cachingAsCBOR

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

import Freckle.App.Prelude

import Blammo.Logging
import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
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.Exception (annotatedExceptionMessage)
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 Freckle.App.Memcached.MD5
import Freckle.App.OpenTelemetry

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 CachingError
  = CacheGetError SomeException
  | CacheSetError SomeException
  | CacheDeserializeError String
  deriving stock (Int -> CachingError -> ShowS
[CachingError] -> ShowS
CachingError -> String
(Int -> CachingError -> ShowS)
-> (CachingError -> String)
-> ([CachingError] -> ShowS)
-> Show CachingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CachingError -> ShowS
showsPrec :: Int -> CachingError -> ShowS
$cshow :: CachingError -> String
show :: CachingError -> String
$cshowList :: [CachingError] -> ShowS
showList :: [CachingError] -> ShowS
Show)

instance Exception CachingError where
  displayException :: CachingError -> String
displayException = \case
    CacheGetError SomeException
ex -> String
"Unable to get: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex
    CacheSetError SomeException
ex -> String
"Unable to set: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex
    CacheDeserializeError String
err -> String
"Unable to deserialize: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err

-- | Log any thrown 'CachingError's as warnings and return the given value
warnOnCachingError :: (MonadUnliftIO m, MonadLogger m) => a -> m a -> m a
warnOnCachingError :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
warnOnCachingError a
val =
  (m a -> (AnnotatedException CachingError -> m a) -> m a)
-> (AnnotatedException CachingError -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (AnnotatedException CachingError -> m a) -> m a
forall e (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
m a -> (e -> m a) -> m a
catch ((AnnotatedException CachingError -> m a) -> m a -> m a)
-> (AnnotatedException CachingError -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
    (a
val a -> m () -> m a
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
      (m () -> m a)
-> (AnnotatedException CachingError -> m ())
-> AnnotatedException CachingError
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Message -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Text -> Message -> m ()
logWarnNS Text
"caching"
      (Message -> m ())
-> (AnnotatedException CachingError -> Message)
-> AnnotatedException CachingError
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ex. Exception ex => AnnotatedException ex -> Message
annotatedExceptionMessage @CachingError

-- | Memoize an action using Memcached and 'Cachable'
caching
  :: ( MonadUnliftIO m
     , MonadLogger m
     , MonadTracer m
     , MonadReader env m
     , HasMemcachedClient env
     , Cachable a
     , HasCallStack
     )
  => CacheKey
  -> CacheTTL
  -> m a
  -> m a
caching :: forall (m :: * -> *) env a.
(MonadUnliftIO m, MonadLogger m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env, Cachable a, HasCallStack) =>
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, MonadTracer m, MonadReader env m,
 HasMemcachedClient env, HasCallStack) =>
(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
     , MonadTracer m
     , MonadReader env m
     , HasMemcachedClient env
     , HasCallStack
     )
  => (ByteString -> Either String a)
  -> (a -> ByteString)
  -> CacheKey
  -> CacheTTL
  -> m a
  -> m a
cachingAs :: forall (m :: * -> *) env a.
(MonadUnliftIO m, MonadLogger m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env, HasCallStack) =>
(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
  Maybe a
mCached <- Maybe a -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
warnOnCachingError Maybe a
forall a. Maybe a
Nothing (m (Maybe a) -> m (Maybe a)) -> m (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ (ByteString -> m a) -> Maybe ByteString -> m (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ByteString -> m a
cacheDeserialize (Maybe ByteString -> m (Maybe a))
-> m (Maybe ByteString) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe ByteString)
cacheGet
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
store a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
mCached
 where
  store :: m a
store = do
    a
a <- m a
f
    a
a a -> m () -> m a
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ () -> m () -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
warnOnCachingError () (a -> m ()
cacheSet a
a)

  cacheGet :: m (Maybe ByteString)
cacheGet = (m (Maybe ByteString)
 -> (SomeException -> m (Maybe ByteString)) -> m (Maybe ByteString))
-> (SomeException -> m (Maybe ByteString))
-> m (Maybe ByteString)
-> m (Maybe ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Maybe ByteString)
-> (SomeException -> m (Maybe ByteString)) -> m (Maybe ByteString)
forall e (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
m a -> (e -> m a) -> m a
catch (CachingError -> m (Maybe ByteString)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, HasCallStack) =>
e -> m a
throwM (CachingError -> m (Maybe ByteString))
-> (SomeException -> CachingError)
-> SomeException
-> m (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> CachingError
CacheGetError) (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.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> m (Maybe ByteString)
Memcached.get CacheKey
key
  cacheSet :: a -> m ()
cacheSet a
a = (m () -> (SomeException -> m ()) -> m ())
-> (SomeException -> m ()) -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip m () -> (SomeException -> m ()) -> m ()
forall e (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
m a -> (e -> m a) -> m a
catch (CachingError -> m ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, HasCallStack) =>
e -> m a
throwM (CachingError -> m ())
-> (SomeException -> CachingError) -> SomeException -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> CachingError
CacheSetError) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ CacheKey -> ByteString -> CacheTTL -> m ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> ByteString -> CacheTTL -> m ()
Memcached.set CacheKey
key (a -> ByteString
to a
a) CacheTTL
ttl
  cacheDeserialize :: ByteString -> m a
cacheDeserialize = (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CachingError -> m a
forall e (m :: * -> *) a.
(Exception e, MonadIO m, HasCallStack) =>
e -> m a
throwM (CachingError -> m a) -> (String -> CachingError) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CachingError
CacheDeserializeError) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> m a)
-> (ByteString -> Either String a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
from

-- | Like 'caching', but de/serializing the value as JSON
cachingAsJSON
  :: ( MonadUnliftIO m
     , MonadLogger m
     , MonadTracer m
     , MonadReader env m
     , HasMemcachedClient env
     , FromJSON a
     , ToJSON a
     , HasCallStack
     )
  => CacheKey
  -> CacheTTL
  -> m a
  -> m a
cachingAsJSON :: forall (m :: * -> *) env a.
(MonadUnliftIO m, MonadLogger m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env, FromJSON a, ToJSON a, HasCallStack) =>
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, MonadTracer m, MonadReader env m,
 HasMemcachedClient env, HasCallStack) =>
(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

-- | Cache data in memcached in CBOR format
cachingAsCBOR
  :: ( MonadUnliftIO m
     , MonadLogger m
     , MonadTracer m
     , MonadReader env m
     , HasMemcachedClient env
     , Serialise a
     , HasCallStack
     )
  => CacheKey
  -> CacheTTL
  -> m a
  -> m a
cachingAsCBOR :: forall (m :: * -> *) env a.
(MonadUnliftIO m, MonadLogger m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env, Serialise a, HasCallStack) =>
CacheKey -> CacheTTL -> m a -> m a
cachingAsCBOR =
  (ByteString -> Either String a)
-> (a -> ByteString) -> CacheKey -> CacheTTL -> m a -> m a
forall (m :: * -> *) env a.
(MonadUnliftIO m, MonadLogger m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env, HasCallStack) =>
(ByteString -> Either String a)
-> (a -> ByteString) -> CacheKey -> CacheTTL -> m a -> m a
cachingAs
    ((DeserialiseFailure -> String)
-> Either DeserialiseFailure a -> Either String a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DeserialiseFailure -> String
forall a. Show a => a -> String
show (Either DeserialiseFailure a -> Either String a)
-> (ByteString -> Either DeserialiseFailure a)
-> ByteString
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either DeserialiseFailure a
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFail (ByteString -> Either DeserialiseFailure a)
-> (ByteString -> ByteString)
-> ByteString
-> Either DeserialiseFailure a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict)
    (ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Serialise a => a -> ByteString
serialise)

encodeStrict :: ToJSON a => a -> ByteString
encodeStrict :: forall a. ToJSON a => 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