{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}

-- | HTTP caching via 'MonadState'
--
-- This module implements HTTP caching for simple use-cases, such as testing
-- "Freckle.App.Http.Cache" itself.
module Freckle.App.Http.Cache.State
  ( CachedResponse (..)
  , Cache (..)
  , HasCache (..)
  , stateHttpCacheSettings
  , stateHttpCacheCodec
  , stateHttpCache
  ) where

import Freckle.App.Prelude

import Blammo.Logging (Message)
import Control.Lens (Lens', at, lens, use, (.=), (?=))
import Control.Monad.Logger (ToLogStr (..), fromLogStr)
import Control.Monad.State
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as T
import Freckle.App.Http.Cache
import Freckle.App.Memcached.CacheKey
import Freckle.App.Memcached.CacheTTL
import System.IO (stderr)

newtype Cache = Cache
  { Cache -> HashMap CacheKey CachedResponse
map :: HashMap CacheKey CachedResponse
  }
  deriving newtype (NonEmpty Cache -> Cache
Cache -> Cache -> Cache
(Cache -> Cache -> Cache)
-> (NonEmpty Cache -> Cache)
-> (forall b. Integral b => b -> Cache -> Cache)
-> Semigroup Cache
forall b. Integral b => b -> Cache -> Cache
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Cache -> Cache -> Cache
<> :: Cache -> Cache -> Cache
$csconcat :: NonEmpty Cache -> Cache
sconcat :: NonEmpty Cache -> Cache
$cstimes :: forall b. Integral b => b -> Cache -> Cache
stimes :: forall b. Integral b => b -> Cache -> Cache
Semigroup, Semigroup Cache
Cache
Semigroup Cache =>
Cache
-> (Cache -> Cache -> Cache) -> ([Cache] -> Cache) -> Monoid Cache
[Cache] -> Cache
Cache -> Cache -> Cache
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Cache
mempty :: Cache
$cmappend :: Cache -> Cache -> Cache
mappend :: Cache -> Cache -> Cache
$cmconcat :: [Cache] -> Cache
mconcat :: [Cache] -> Cache
Monoid)

mapL :: Lens' Cache (HashMap CacheKey CachedResponse)
mapL :: Lens' Cache (HashMap CacheKey CachedResponse)
mapL = (Cache -> HashMap CacheKey CachedResponse)
-> (Cache -> HashMap CacheKey CachedResponse -> Cache)
-> Lens' Cache (HashMap CacheKey CachedResponse)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.map) ((Cache -> HashMap CacheKey CachedResponse -> Cache)
 -> Lens' Cache (HashMap CacheKey CachedResponse))
-> (Cache -> HashMap CacheKey CachedResponse -> Cache)
-> Lens' Cache (HashMap CacheKey CachedResponse)
forall a b. (a -> b) -> a -> b
$ \Cache
x HashMap CacheKey CachedResponse
y -> Cache
x {map = y}

class HasCache env where
  cacheL :: Lens' env Cache

instance HasCache Cache where
  cacheL :: Lens' Cache Cache
cacheL = (Cache -> f Cache) -> Cache -> f Cache
forall a. a -> a
id

stateHttpCacheSettings
  :: ( MonadIO m
     , MonadState s m
     , HasCache s
     )
  => HttpCacheSettings m CachedResponse
stateHttpCacheSettings :: forall (m :: * -> *) s.
(MonadIO m, MonadState s m, HasCache s) =>
HttpCacheSettings m CachedResponse
stateHttpCacheSettings =
  HttpCacheSettings
    { $sel:shared:HttpCacheSettings :: Bool
shared = Bool
False
    , $sel:cacheable:HttpCacheSettings :: Request -> Bool
cacheable = Bool -> Request -> Bool
forall a b. a -> b -> a
const Bool
True
    , $sel:defaultTTL:HttpCacheSettings :: CacheTTL
defaultTTL = CacheTTL
fiveMinuteTTL
    , $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 = \Message
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , $sel:logWarn:HttpCacheSettings :: Message -> m ()
logWarn = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Message -> IO ()) -> Message -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> (Message -> Text) -> Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Text
messageToText
    , $sel:codec:HttpCacheSettings :: HttpCacheCodec CachedResponse
codec = HttpCacheCodec CachedResponse
stateHttpCacheCodec
    , $sel:cache:HttpCacheSettings :: HttpCache m CachedResponse
cache = HttpCache m CachedResponse
forall (m :: * -> *) s.
(MonadIO m, MonadState s m, HasCache s) =>
HttpCache m CachedResponse
stateHttpCache
    }

stateHttpCacheCodec :: HttpCacheCodec CachedResponse
stateHttpCacheCodec :: HttpCacheCodec CachedResponse
stateHttpCacheCodec =
  HttpCacheCodec
    { $sel:serialise:HttpCacheCodec :: CachedResponse -> CachedResponse
serialise = CachedResponse -> CachedResponse
forall a. a -> a
id
    , $sel:deserialise:HttpCacheCodec :: Request -> CachedResponse -> Either String CachedResponse
deserialise = (CachedResponse -> Either String CachedResponse)
-> Request -> CachedResponse -> Either String CachedResponse
forall a b. a -> b -> a
const CachedResponse -> Either String CachedResponse
forall a b. b -> Either a b
Right
    }

stateHttpCache
  :: (MonadIO m, MonadState s m, HasCache s) => HttpCache m CachedResponse
stateHttpCache :: forall (m :: * -> *) s.
(MonadIO m, MonadState s m, HasCache s) =>
HttpCache m CachedResponse
stateHttpCache =
  HttpCache
    { $sel:get:HttpCache :: CacheKey -> m (Either SomeException (Maybe CachedResponse))
get = \CacheKey
key -> (Maybe CachedResponse
 -> Either SomeException (Maybe CachedResponse))
-> m (Maybe CachedResponse)
-> m (Either SomeException (Maybe CachedResponse))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe CachedResponse -> Either SomeException (Maybe CachedResponse)
forall a b. b -> Either a b
Right (m (Maybe CachedResponse)
 -> m (Either SomeException (Maybe CachedResponse)))
-> m (Maybe CachedResponse)
-> m (Either SomeException (Maybe CachedResponse))
forall a b. (a -> b) -> a -> b
$ Getting (Maybe CachedResponse) s (Maybe CachedResponse)
-> m (Maybe CachedResponse)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting (Maybe CachedResponse) s (Maybe CachedResponse)
 -> m (Maybe CachedResponse))
-> Getting (Maybe CachedResponse) s (Maybe CachedResponse)
-> m (Maybe CachedResponse)
forall a b. (a -> b) -> a -> b
$ (Cache -> Const (Maybe CachedResponse) Cache)
-> s -> Const (Maybe CachedResponse) s
forall env. HasCache env => Lens' env Cache
Lens' s Cache
cacheL ((Cache -> Const (Maybe CachedResponse) Cache)
 -> s -> Const (Maybe CachedResponse) s)
-> ((Maybe CachedResponse
     -> Const (Maybe CachedResponse) (Maybe CachedResponse))
    -> Cache -> Const (Maybe CachedResponse) Cache)
-> Getting (Maybe CachedResponse) s (Maybe CachedResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap CacheKey CachedResponse
 -> Const (Maybe CachedResponse) (HashMap CacheKey CachedResponse))
-> Cache -> Const (Maybe CachedResponse) Cache
Lens' Cache (HashMap CacheKey CachedResponse)
mapL ((HashMap CacheKey CachedResponse
  -> Const (Maybe CachedResponse) (HashMap CacheKey CachedResponse))
 -> Cache -> Const (Maybe CachedResponse) Cache)
-> ((Maybe CachedResponse
     -> Const (Maybe CachedResponse) (Maybe CachedResponse))
    -> HashMap CacheKey CachedResponse
    -> Const (Maybe CachedResponse) (HashMap CacheKey CachedResponse))
-> (Maybe CachedResponse
    -> Const (Maybe CachedResponse) (Maybe CachedResponse))
-> Cache
-> Const (Maybe CachedResponse) Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap CacheKey CachedResponse)
-> Lens'
     (HashMap CacheKey CachedResponse)
     (Maybe (IxValue (HashMap CacheKey CachedResponse)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap CacheKey CachedResponse)
CacheKey
key
    , $sel:set:HttpCache :: CacheKey -> CachedResponse -> m (Either SomeException ())
set = \CacheKey
key CachedResponse
resp -> (() -> Either SomeException ())
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either SomeException ()
forall a b. b -> Either a b
Right (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (Cache -> Identity Cache) -> s -> Identity s
forall env. HasCache env => Lens' env Cache
Lens' s Cache
cacheL ((Cache -> Identity Cache) -> s -> Identity s)
-> ((Maybe CachedResponse -> Identity (Maybe CachedResponse))
    -> Cache -> Identity Cache)
-> (Maybe CachedResponse -> Identity (Maybe CachedResponse))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap CacheKey CachedResponse
 -> Identity (HashMap CacheKey CachedResponse))
-> Cache -> Identity Cache
Lens' Cache (HashMap CacheKey CachedResponse)
mapL ((HashMap CacheKey CachedResponse
  -> Identity (HashMap CacheKey CachedResponse))
 -> Cache -> Identity Cache)
-> ((Maybe CachedResponse -> Identity (Maybe CachedResponse))
    -> HashMap CacheKey CachedResponse
    -> Identity (HashMap CacheKey CachedResponse))
-> (Maybe CachedResponse -> Identity (Maybe CachedResponse))
-> Cache
-> Identity Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap CacheKey CachedResponse)
-> Lens'
     (HashMap CacheKey CachedResponse)
     (Maybe (IxValue (HashMap CacheKey CachedResponse)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap CacheKey CachedResponse)
CacheKey
key ((Maybe CachedResponse -> Identity (Maybe CachedResponse))
 -> s -> Identity s)
-> CachedResponse -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= CachedResponse
resp
    , $sel:evict:HttpCache :: CacheKey -> m (Either SomeException ())
evict = \CacheKey
key -> (() -> Either SomeException ())
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either SomeException ()
forall a b. b -> Either a b
Right (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (Cache -> Identity Cache) -> s -> Identity s
forall env. HasCache env => Lens' env Cache
Lens' s Cache
cacheL ((Cache -> Identity Cache) -> s -> Identity s)
-> ((Maybe CachedResponse -> Identity (Maybe CachedResponse))
    -> Cache -> Identity Cache)
-> (Maybe CachedResponse -> Identity (Maybe CachedResponse))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap CacheKey CachedResponse
 -> Identity (HashMap CacheKey CachedResponse))
-> Cache -> Identity Cache
Lens' Cache (HashMap CacheKey CachedResponse)
mapL ((HashMap CacheKey CachedResponse
  -> Identity (HashMap CacheKey CachedResponse))
 -> Cache -> Identity Cache)
-> ((Maybe CachedResponse -> Identity (Maybe CachedResponse))
    -> HashMap CacheKey CachedResponse
    -> Identity (HashMap CacheKey CachedResponse))
-> (Maybe CachedResponse -> Identity (Maybe CachedResponse))
-> Cache
-> Identity Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap CacheKey CachedResponse)
-> Lens'
     (HashMap CacheKey CachedResponse)
     (Maybe (IxValue (HashMap CacheKey CachedResponse)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap CacheKey CachedResponse)
CacheKey
key ((Maybe CachedResponse -> Identity (Maybe CachedResponse))
 -> s -> Identity s)
-> Maybe CachedResponse -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe CachedResponse
forall a. Maybe a
Nothing
    }

messageToText :: Message -> Text
messageToText :: Message -> Text
messageToText = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> (Message -> ByteString) -> Message -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
fromLogStr (LogStr -> ByteString)
-> (Message -> LogStr) -> Message -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr