{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Freckle.App.Http.Cache.Memcached
  ( memcachedHttpCacheSettings
  , memcachedHttpCodec
  , memcachedHttpCache
  ) where

import Freckle.App.Prelude

import Blammo.Logging (MonadLogger, logDebugNS, logWarnNS)
import Codec.Serialise (Serialise (..), deserialiseOrFail, serialise)
import qualified Data.ByteString.Lazy as BSL
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Database.Memcache.Types (Value)
import Freckle.App.Http.Cache
import Freckle.App.Memcached
import qualified Freckle.App.Memcached.Client as Memcached
import Freckle.App.OpenTelemetry (MonadTracer)
import Network.HTTP.Client (Request)
import qualified Network.HTTP.Client.Internal as HTTP
import Network.HTTP.Types.Header (ResponseHeaders)
import Network.HTTP.Types.Status (Status (..))
import Network.HTTP.Types.Version (HttpVersion (..))

memcachedHttpCacheSettings
  :: ( MonadUnliftIO m
     , MonadLogger m
     , MonadTracer m
     , MonadReader env m
     , HasMemcachedClient env
     )
  => CacheTTL
  -- ^ Default TTL, used when @max-age@ is not present
  -> HttpCacheSettings m Value
memcachedHttpCacheSettings :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadLogger m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheTTL -> HttpCacheSettings m Value
memcachedHttpCacheSettings CacheTTL
defaultTTL =
  HttpCacheSettings
    { $sel:shared:HttpCacheSettings :: Bool
shared = Bool
True
    , $sel:cacheable:HttpCacheSettings :: Request -> Bool
cacheable = Bool -> Request -> Bool
forall a b. a -> b -> a
const Bool
True
    , CacheTTL
defaultTTL :: CacheTTL
$sel:defaultTTL:HttpCacheSettings :: CacheTTL
defaultTTL
    , $sel:getCurrentTime:HttpCacheSettings :: m UTCTime
getCurrentTime = IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    , $sel:logDebug:HttpCacheSettings :: Message -> m ()
logDebug = LogSource -> Message -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
LogSource -> Message -> m ()
logDebugNS LogSource
"http.cache"
    , $sel:logWarn:HttpCacheSettings :: Message -> m ()
logWarn = LogSource -> Message -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
LogSource -> Message -> m ()
logWarnNS LogSource
"http.cache"
    , $sel:codec:HttpCacheSettings :: HttpCacheCodec Value
codec = HttpCacheCodec Value
memcachedHttpCodec
    , $sel:cache:HttpCacheSettings :: HttpCache m Value
cache = HttpCache m Value
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
HttpCache m Value
memcachedHttpCache
    }

memcachedHttpCodec :: HttpCacheCodec Value
memcachedHttpCodec :: HttpCacheCodec Value
memcachedHttpCodec =
  HttpCacheCodec
    { $sel:serialise:HttpCacheCodec :: CachedResponse -> Value
serialise = ByteString -> Value
BSL.toStrict (ByteString -> Value)
-> (CachedResponse -> ByteString) -> CachedResponse -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialiseResponse -> ByteString
forall a. Serialise a => a -> ByteString
serialise (SerialiseResponse -> ByteString)
-> (CachedResponse -> SerialiseResponse)
-> CachedResponse
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CachedResponse -> SerialiseResponse
fromResponse
    , $sel:deserialise:HttpCacheCodec :: Request -> Value -> Either String CachedResponse
deserialise = \Request
req ->
        (DeserialiseFailure -> String)
-> (SerialiseResponse -> CachedResponse)
-> Either DeserialiseFailure SerialiseResponse
-> Either String CachedResponse
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap DeserialiseFailure -> String
forall a. Show a => a -> String
show (Request -> SerialiseResponse -> CachedResponse
toResponse Request
req)
          (Either DeserialiseFailure SerialiseResponse
 -> Either String CachedResponse)
-> (Value -> Either DeserialiseFailure SerialiseResponse)
-> Value
-> Either String CachedResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either DeserialiseFailure SerialiseResponse
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFail
          (ByteString -> Either DeserialiseFailure SerialiseResponse)
-> (Value -> ByteString)
-> Value
-> Either DeserialiseFailure SerialiseResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
BSL.fromStrict
    }

memcachedHttpCache
  :: ( MonadUnliftIO m
     , MonadTracer m
     , MonadReader env m
     , HasMemcachedClient env
     )
  => HttpCache m Value
memcachedHttpCache :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
HttpCache m Value
memcachedHttpCache =
  HttpCache
    { $sel:get:HttpCache :: CacheKey -> m (Either SomeException (Maybe Value))
get = m (Maybe Value) -> m (Either SomeException (Maybe Value))
forall e (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
m a -> m (Either e a)
try (m (Maybe Value) -> m (Either SomeException (Maybe Value)))
-> (CacheKey -> m (Maybe Value))
-> CacheKey
-> m (Either SomeException (Maybe Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheKey -> m (Maybe Value)
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> m (Maybe Value)
Memcached.get
    , $sel:set:HttpCache :: CacheKey -> Value -> m (Either SomeException ())
set = \CacheKey
k Value
v -> m () -> m (Either SomeException ())
forall e (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
m a -> m (Either e a)
try (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ CacheKey -> Value -> CacheTTL -> m ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> Value -> CacheTTL -> m ()
Memcached.set CacheKey
k Value
v CacheTTL
0
    , $sel:evict:HttpCache :: CacheKey -> m (Either SomeException ())
evict = m () -> m (Either SomeException ())
forall e (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
m a -> m (Either e a)
try (m () -> m (Either SomeException ()))
-> (CacheKey -> m ()) -> CacheKey -> m (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheKey -> m ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadTracer m, MonadReader env m,
 HasMemcachedClient env) =>
CacheKey -> m ()
Memcached.delete
    }

-- | Representation of 'CachedResponse' that can be given a 'Serialise' instance
--
-- In 'fromResponse' we need to flatten the 'Response' down and remove fields
-- that can't (or shouldn't) be cached, then restore them again later in
-- 'toResponse'.
data SerialiseResponse = SerialiseResponse
  { SerialiseResponse -> Status
sresponseStatus :: Status
  , SerialiseResponse -> HttpVersion
sresponseVersion :: HttpVersion
  , SerialiseResponse -> ResponseHeaders
sresponseHeaders :: ResponseHeaders
  , SerialiseResponse -> PotentiallyGzipped ByteString
sresponseBody :: PotentiallyGzipped BSL.ByteString
  , SerialiseResponse -> ResponseHeaders
sresponseEarlyHints :: ResponseHeaders
  , SerialiseResponse -> UTCTime
sinserted :: UTCTime
  , SerialiseResponse -> CacheTTL
sttl :: CacheTTL
  }
  deriving stock ((forall x. SerialiseResponse -> Rep SerialiseResponse x)
-> (forall x. Rep SerialiseResponse x -> SerialiseResponse)
-> Generic SerialiseResponse
forall x. Rep SerialiseResponse x -> SerialiseResponse
forall x. SerialiseResponse -> Rep SerialiseResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SerialiseResponse -> Rep SerialiseResponse x
from :: forall x. SerialiseResponse -> Rep SerialiseResponse x
$cto :: forall x. Rep SerialiseResponse x -> SerialiseResponse
to :: forall x. Rep SerialiseResponse x -> SerialiseResponse
Generic)
  deriving anyclass ([SerialiseResponse] -> Encoding
SerialiseResponse -> Encoding
(SerialiseResponse -> Encoding)
-> (forall s. Decoder s SerialiseResponse)
-> ([SerialiseResponse] -> Encoding)
-> (forall s. Decoder s [SerialiseResponse])
-> Serialise SerialiseResponse
forall s. Decoder s [SerialiseResponse]
forall s. Decoder s SerialiseResponse
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: SerialiseResponse -> Encoding
encode :: SerialiseResponse -> Encoding
$cdecode :: forall s. Decoder s SerialiseResponse
decode :: forall s. Decoder s SerialiseResponse
$cencodeList :: [SerialiseResponse] -> Encoding
encodeList :: [SerialiseResponse] -> Encoding
$cdecodeList :: forall s. Decoder s [SerialiseResponse]
decodeList :: forall s. Decoder s [SerialiseResponse]
Serialise)

{- FOURMOLU_DISABLE -}
-- Fourmolu has trouble with this bit of CPP

toResponse :: Request -> SerialiseResponse -> CachedResponse
toResponse :: Request -> SerialiseResponse -> CachedResponse
toResponse Request
req SerialiseResponse
c = CachedResponse
  { $sel:response:CachedResponse :: Response (PotentiallyGzipped ByteString)
response = HTTP.Response
      { responseStatus :: Status
HTTP.responseStatus = SerialiseResponse -> Status
sresponseStatus SerialiseResponse
c
      , responseVersion :: HttpVersion
HTTP.responseVersion = SerialiseResponse -> HttpVersion
sresponseVersion SerialiseResponse
c
      , responseHeaders :: ResponseHeaders
HTTP.responseHeaders = SerialiseResponse -> ResponseHeaders
sresponseHeaders SerialiseResponse
c
      , responseBody :: PotentiallyGzipped ByteString
HTTP.responseBody = SerialiseResponse -> PotentiallyGzipped ByteString
sresponseBody SerialiseResponse
c
      , responseCookieJar :: CookieJar
HTTP.responseCookieJar = CookieJar
forall a. Monoid a => a
mempty
      , responseClose' :: ResponseClose
HTTP.responseClose' = IO () -> ResponseClose
HTTP.ResponseClose (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      , responseOriginalRequest :: Request
HTTP.responseOriginalRequest = Request
req
#if MIN_VERSION_http_client(0,7,16)
      , responseEarlyHints :: ResponseHeaders
HTTP.responseEarlyHints = SerialiseResponse -> ResponseHeaders
sresponseEarlyHints SerialiseResponse
c
#endif
      }
  , $sel:inserted:CachedResponse :: UTCTime
inserted = SerialiseResponse
c.sinserted
  , $sel:ttl:CachedResponse :: CacheTTL
ttl = SerialiseResponse
c.sttl
  }

fromResponse :: CachedResponse -> SerialiseResponse
fromResponse :: CachedResponse -> SerialiseResponse
fromResponse CachedResponse
cr =
  SerialiseResponse
    { sresponseStatus :: Status
sresponseStatus = Response (PotentiallyGzipped ByteString) -> Status
forall body. Response body -> Status
HTTP.responseStatus Response (PotentiallyGzipped ByteString)
r
    , sresponseVersion :: HttpVersion
sresponseVersion = Response (PotentiallyGzipped ByteString) -> HttpVersion
forall body. Response body -> HttpVersion
HTTP.responseVersion Response (PotentiallyGzipped ByteString)
r
    , sresponseHeaders :: ResponseHeaders
sresponseHeaders = Response (PotentiallyGzipped ByteString) -> ResponseHeaders
forall body. Response body -> ResponseHeaders
HTTP.responseHeaders Response (PotentiallyGzipped ByteString)
r
    , sresponseBody :: PotentiallyGzipped ByteString
sresponseBody = Response (PotentiallyGzipped ByteString)
-> PotentiallyGzipped ByteString
forall body. Response body -> body
HTTP.responseBody Response (PotentiallyGzipped ByteString)
r
#if MIN_VERSION_http_client(0,7,16)
    , sresponseEarlyHints :: ResponseHeaders
sresponseEarlyHints = Response (PotentiallyGzipped ByteString) -> ResponseHeaders
forall body. Response body -> ResponseHeaders
HTTP.responseEarlyHints Response (PotentiallyGzipped ByteString)
r
#else
    , sresponseEarlyHints = []
#endif
    , sinserted :: UTCTime
sinserted = CachedResponse
cr.inserted
    , sttl :: CacheTTL
sttl = CachedResponse
cr.ttl
    }
 where
  r :: Response (PotentiallyGzipped ByteString)
r = CachedResponse
cr.response

#if !MIN_VERSION_http_types(0,12,4)
deriving stock instance Generic HttpVersion

deriving stock instance Generic Status
#endif

{- FOURMOLU_ENABLE -}

deriving anyclass instance Serialise HttpVersion

deriving anyclass instance Serialise Status

instance (CI.FoldCase a, Serialise a) => Serialise (CI a) where
  encode :: CI a -> Encoding
encode = a -> Encoding
forall a. Serialise a => a -> Encoding
encode (a -> Encoding) -> (CI a -> a) -> CI a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI a -> a
forall s. CI s -> s
CI.original
  decode :: forall s. Decoder s (CI a)
decode = a -> CI a
forall s. FoldCase s => s -> CI s
CI.mk (a -> CI a) -> Decoder s a -> Decoder s (CI a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
forall s. Decoder s a
forall a s. Serialise a => Decoder s a
decode