-- | 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 Prelude

import Blammo.Logging
import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
import Control.Exception.Annotated.UnliftIO
  ( AnnotatedException
  , throwWithCallStack
  )
import Control.Exception.Annotated.UnliftIO qualified as AnnotatedException
import Control.Monad.Reader (MonadReader)
import Data.Aeson
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.Text (Text)
import Data.Text.Encoding qualified as T
import Data.Text.Encoding.Error qualified as T
import Freckle.App.Memcached.CacheKey
import Freckle.App.Memcached.CacheTTL
import Freckle.App.Memcached.Client (HasMemcachedClient (..))
import Freckle.App.Memcached.Client qualified as Memcached
import Freckle.App.Memcached.MD5
import Freckle.App.OpenTelemetry
import GHC.Stack (HasCallStack, prettyCallStack)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception

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
T.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
T.decodeUtf8With OnDecodeError
T.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 (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
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 <$)
      (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

annotatedExceptionMessage :: Exception ex => AnnotatedException ex -> Message
annotatedExceptionMessage :: forall ex. Exception ex => AnnotatedException ex -> Message
annotatedExceptionMessage = (ex -> Message) -> AnnotatedException ex -> Message
forall ex.
Exception ex =>
(ex -> Message) -> AnnotatedException ex -> Message
annotatedExceptionMessageFrom ((ex -> Message) -> AnnotatedException ex -> Message)
-> (ex -> Message) -> AnnotatedException ex -> Message
forall a b. (a -> b) -> a -> b
$ Message -> ex -> Message
forall a b. a -> b -> a
const Message
"Exception"

annotatedExceptionMessageFrom
  :: Exception ex => (ex -> Message) -> AnnotatedException ex -> Message
annotatedExceptionMessageFrom :: forall ex.
Exception ex =>
(ex -> Message) -> AnnotatedException ex -> Message
annotatedExceptionMessageFrom ex -> Message
f AnnotatedException ex
ann = case ex -> Message
f ex
ex of
  Text
msg :# [SeriesElem]
series -> Text
msg Text -> [SeriesElem] -> Message
:# [SeriesElem]
series [SeriesElem] -> [SeriesElem] -> [SeriesElem]
forall a. Semigroup a => a -> a -> a
<> [Key
"error" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
errorObject]
 where
  ex :: ex
ex = AnnotatedException ex -> ex
forall exception. AnnotatedException exception -> exception
AnnotatedException.exception AnnotatedException ex
ann
  errorObject :: Value
errorObject =
    [Pair] -> Value
object
      [ Key
"message" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ex -> String
forall e. Exception e => e -> String
displayException ex
ex
      , Key
"stack"
          Key -> Maybe String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (CallStack -> String
prettyCallStack (CallStack -> String) -> Maybe CallStack -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotatedException ex -> Maybe CallStack
forall exception. AnnotatedException exception -> Maybe CallStack
AnnotatedException.annotatedExceptionCallStack AnnotatedException ex
ann)
      ]

-- | 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 (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (CachingError -> m (Maybe ByteString)
forall e (m :: * -> *) a.
(MonadIO m, Exception e, HasCallStack) =>
e -> m a
throwWithCallStack (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 (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (CachingError -> m ()
forall e (m :: * -> *) a.
(MonadIO m, Exception e, HasCallStack) =>
e -> m a
throwWithCallStack (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.
(MonadIO m, Exception e, HasCallStack) =>
e -> m a
throwWithCallStack (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