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

-- | Cache HTTP responses like a CDN or browser would
module Freckle.App.Http.Cache
  ( HttpCacheSettings (..)
  , HttpCacheCodec (..)
  , HttpCache (..)
  , httpCached
  , CachedResponse (..)
  , PotentiallyGzipped
  ) where

import Freckle.App.Prelude

import Blammo.Logging (Message (..), (.=))
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as BSL
import Data.CaseInsensitive qualified as CI
import Data.List.Extra (firstJust)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time (addUTCTime, defaultTimeLocale, parseTimeM)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Freckle.App.Http.Cache.Gzip
import Freckle.App.Http.Header
import Freckle.App.Memcached
import Network.HTTP.Client (Request, Response)
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Simple
  ( addRequestHeader
  , getRequestHeader
  , getResponseStatus
  )
import Network.HTTP.Types.Header
  ( HeaderName
  , hAge
  , hCacheControl
  , hETag
  , hExpires
  , hIfNoneMatch
  , hVary
  )
import Network.HTTP.Types.Status (Status, statusCode)

data HttpCacheSettings m t = HttpCacheSettings
  { forall (m :: * -> *) t. HttpCacheSettings m t -> Bool
shared :: Bool
  , forall (m :: * -> *) t. HttpCacheSettings m t -> Request -> Bool
cacheable :: Request -> Bool
  , forall (m :: * -> *) t. HttpCacheSettings m t -> CacheTTL
defaultTTL :: CacheTTL
  , forall (m :: * -> *) t. HttpCacheSettings m t -> m UTCTime
getCurrentTime :: m UTCTime
  , forall (m :: * -> *) t. HttpCacheSettings m t -> Message -> m ()
logDebug :: Message -> m ()
  , forall (m :: * -> *) t. HttpCacheSettings m t -> Message -> m ()
logWarn :: Message -> m ()
  , forall (m :: * -> *) t. HttpCacheSettings m t -> HttpCacheCodec t
codec :: HttpCacheCodec t
  , forall (m :: * -> *) t. HttpCacheSettings m t -> HttpCache m t
cache :: HttpCache m t
  }

data HttpCacheCodec t = HttpCacheCodec
  { forall t. HttpCacheCodec t -> CachedResponse -> t
serialise :: CachedResponse -> t
  , forall t.
HttpCacheCodec t -> Request -> t -> Either String CachedResponse
deserialise :: Request -> t -> Either String CachedResponse
  }

data HttpCache m t = HttpCache
  { forall (m :: * -> *) t.
HttpCache m t -> CacheKey -> m (Either SomeException (Maybe t))
get :: CacheKey -> m (Either SomeException (Maybe t))
  , forall (m :: * -> *) t.
HttpCache m t -> CacheKey -> t -> m (Either SomeException ())
set :: CacheKey -> t -> m (Either SomeException ())
  , forall (m :: * -> *) t.
HttpCache m t -> CacheKey -> m (Either SomeException ())
evict :: CacheKey -> m (Either SomeException ())
  }

data CachedResponse = CachedResponse
  { CachedResponse -> Response (PotentiallyGzipped ByteString)
response :: Response (PotentiallyGzipped BSL.ByteString)
  , CachedResponse -> UTCTime
inserted :: UTCTime
  , CachedResponse -> CacheTTL
ttl :: CacheTTL
  }
  deriving stock (Int -> CachedResponse -> ShowS
[CachedResponse] -> ShowS
CachedResponse -> String
(Int -> CachedResponse -> ShowS)
-> (CachedResponse -> String)
-> ([CachedResponse] -> ShowS)
-> Show CachedResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CachedResponse -> ShowS
showsPrec :: Int -> CachedResponse -> ShowS
$cshow :: CachedResponse -> String
show :: CachedResponse -> String
$cshowList :: [CachedResponse] -> ShowS
showList :: [CachedResponse] -> ShowS
Show)

isCachedResponseStale :: CachedResponse -> UTCTime -> Bool
isCachedResponseStale :: CachedResponse -> UTCTime -> Bool
isCachedResponseStale CachedResponse
cached UTCTime
now =
  POSIXTime -> UTCTime -> UTCTime
addUTCTime (CacheTTL -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral CachedResponse
cached.ttl) CachedResponse
cached.inserted UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now

-- Wrap a function from "Freckle.App.Http" with caching
--
-- Verify that the request is cacheable (e.g. a @GET@), then cache it at a
-- derived key (from URL and considering any @Vary@ headers). The response will
-- only be cached if @Cache-Control@ allows it. @Cache-Control@ is also used to
-- determine TTL (e.g. @max-age@)
--
-- - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching#vary>
-- - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching#fresh_and_stale_based_on_age>
--
-- If a cached response is stale, but it has an @ETag@ header, we will make the
-- request using @If-None-Match@ and still return (and retain) that cached
-- response if we receive a @304@ response.
--
-- - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/ETag#caching_of_unchanged_resources>
--
httpCached
  :: forall m t
   . MonadIO m
  => HttpCacheSettings m t
  -> (Request -> m (Response BSL.ByteString))
  -> Request
  -> m (Response BSL.ByteString)
httpCached :: forall (m :: * -> *) t.
MonadIO m =>
HttpCacheSettings m t
-> (Request -> m (Response ByteString))
-> Request
-> m (Response ByteString)
httpCached HttpCacheSettings m t
settings Request -> m (Response ByteString)
doHttp Request
req =
  m (Response ByteString)
-> (CacheKey -> m (Response ByteString))
-> Maybe CacheKey
-> m (Response ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Request -> m (Response ByteString)
doHttp Request
req) CacheKey -> m (Response ByteString)
handleCachableRequest (Maybe CacheKey -> m (Response ByteString))
-> Maybe CacheKey -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ HttpCacheSettings m t -> Request -> Maybe CacheKey
forall (m :: * -> *) t.
HttpCacheSettings m t -> Request -> Maybe CacheKey
getCachableRequestKey HttpCacheSettings m t
settings Request
req
 where
  handleCachableRequest :: CacheKey -> m (Response ByteString)
handleCachableRequest CacheKey
key = do
    UTCTime
now <- HttpCacheSettings m t
settings.getCurrentTime
    Maybe t
result <- Maybe t -> m (Either SomeException (Maybe t)) -> m (Maybe t)
forall a. a -> m (Either SomeException a) -> m a
fromEx Maybe t
forall a. Maybe a
Nothing (m (Either SomeException (Maybe t)) -> m (Maybe t))
-> m (Either SomeException (Maybe t)) -> m (Maybe t)
forall a b. (a -> b) -> a -> b
$ HttpCacheSettings m t
settings.cache.get CacheKey
key

    let tkey :: Text
tkey = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CacheKey -> ByteString
fromCacheKey CacheKey
key

    case Maybe t
result of
      Maybe t
Nothing -> do
        HttpCacheSettings m t
settings.logDebug (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Cache miss" Text -> [SeriesElem] -> Message
:# [Key
"key" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tkey]
        UTCTime
-> CacheKey
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
writeCache UTCTime
now CacheKey
key (Response (PotentiallyGzipped ByteString)
 -> m (Response ByteString))
-> m (Response (PotentiallyGzipped ByteString))
-> m (Response ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> m (Response (PotentiallyGzipped ByteString))
getResponse Request
req
      Just t
val -> do
        HttpCacheSettings m t
settings.logDebug (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Cache hit" Text -> [SeriesElem] -> Message
:# [Key
"key" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tkey]
        case HttpCacheSettings m t
settings.codec.deserialise Request
req t
val of
          Left String
err -> do
            HttpCacheSettings m t
settings.logWarn (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Error deserialising" Text -> [SeriesElem] -> Message
:# [Key
"error" Key -> String -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
err]
            UTCTime
-> CacheKey
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
writeCache UTCTime
now CacheKey
key (Response (PotentiallyGzipped ByteString)
 -> m (Response ByteString))
-> m (Response (PotentiallyGzipped ByteString))
-> m (Response ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> m (Response (PotentiallyGzipped ByteString))
getResponse Request
req
          Right CachedResponse
cresp | CachedResponse -> UTCTime -> Bool
isCachedResponseStale CachedResponse
cresp UTCTime
now -> do
            HttpCacheSettings m t
settings.logDebug (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$
              Text
"Cached value stale"
                Text -> [SeriesElem] -> Message
:# [ Key
"key" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tkey
                   , Key
"inserted" Key -> UTCTime -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CachedResponse
cresp.inserted
                   , Key
"ttl" Key -> Expiration -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CacheTTL -> Expiration
fromCacheTTL CachedResponse
cresp.ttl
                   , Key
"now" Key -> UTCTime -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
now
                   ]
            case HeaderName
-> Response (PotentiallyGzipped ByteString) -> Maybe ByteString
forall a. HasHeaders a => HeaderName -> a -> Maybe ByteString
lookupHeader HeaderName
hETag CachedResponse
cresp.response of
              Maybe ByteString
Nothing -> do
                () -> m (Either SomeException ()) -> m ()
forall a. a -> m (Either SomeException a) -> m a
fromEx () (m (Either SomeException ()) -> m ())
-> m (Either SomeException ()) -> m ()
forall a b. (a -> b) -> a -> b
$ HttpCacheSettings m t
settings.cache.evict CacheKey
key
                UTCTime
-> CacheKey
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
writeCache UTCTime
now CacheKey
key (Response (PotentiallyGzipped ByteString)
 -> m (Response ByteString))
-> m (Response (PotentiallyGzipped ByteString))
-> m (Response ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> m (Response (PotentiallyGzipped ByteString))
getResponse Request
req
              Just ByteString
etag -> do
                HttpCacheSettings m t
settings.logDebug (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$
                  Text
"Retrying with If-None-Match"
                    Text -> [SeriesElem] -> Message
:# [ Key
"key" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tkey
                       , Key
"etag" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
etag
                       ]
                Response (PotentiallyGzipped ByteString)
resp <- Request -> m (Response (PotentiallyGzipped ByteString))
getResponse (Request -> m (Response (PotentiallyGzipped ByteString)))
-> Request -> m (Response (PotentiallyGzipped ByteString))
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hIfNoneMatch ByteString
etag Request
req
                case Status -> Int
statusCode (Response (PotentiallyGzipped ByteString) -> Status
forall a. Response a -> Status
getResponseStatus Response (PotentiallyGzipped ByteString)
resp) of
                  Int
304 -> do
                    HttpCacheSettings m t
settings.logDebug Message
"ETag matched (304), retaining cached response"

                    -- We want to rewrite the cache entry based on Cache-Control
                    -- from base do now. Otherwise, we'll continue to treat it
                    -- as stale and do this 304 dance every time. But we use the
                    -- Cache-Control header from this response, in case it
                    -- differs
                    UTCTime
-> CacheKey
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
writeCache UTCTime
now CacheKey
key (Response (PotentiallyGzipped ByteString)
 -> m (Response ByteString))
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Response (PotentiallyGzipped ByteString)
-> Response (PotentiallyGzipped ByteString)
-> Response (PotentiallyGzipped ByteString)
forall a b. Response a -> Response b -> Response b
setCacheControlFrom Response (PotentiallyGzipped ByteString)
resp CachedResponse
cresp.response
                  Int
_ -> do
                    HttpCacheSettings m t
settings.logDebug Message
"ETag not matched, evicting cache"
                    () -> m (Either SomeException ()) -> m ()
forall a. a -> m (Either SomeException a) -> m a
fromEx () (m (Either SomeException ()) -> m ())
-> m (Either SomeException ()) -> m ()
forall a b. (a -> b) -> a -> b
$ HttpCacheSettings m t
settings.cache.evict CacheKey
key
                    UTCTime
-> CacheKey
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
writeCache UTCTime
now CacheKey
key Response (PotentiallyGzipped ByteString)
resp
          Right CachedResponse
cresp -> Request
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
gunzipResponseBody Request
req CachedResponse
cresp.response

  getResponse :: Request -> m (Response (PotentiallyGzipped BSL.ByteString))
  getResponse :: Request -> m (Response (PotentiallyGzipped ByteString))
getResponse = (Request -> m (Response ByteString))
-> Request -> m (Response (PotentiallyGzipped ByteString))
forall (m :: * -> *) body.
Functor m =>
(Request -> m (Response body))
-> Request -> m (Response (PotentiallyGzipped body))
requestPotentiallyGzipped Request -> m (Response ByteString)
doHttp

  writeCache
    :: UTCTime
    -> CacheKey
    -> Response (PotentiallyGzipped BSL.ByteString)
    -> m (Response BSL.ByteString)
  writeCache :: UTCTime
-> CacheKey
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
writeCache UTCTime
now CacheKey
key Response (PotentiallyGzipped ByteString)
resp = do
    Maybe CacheTTL -> (CacheTTL -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (HttpCacheSettings m t
-> Response (PotentiallyGzipped ByteString) -> Maybe CacheTTL
forall (m :: * -> *) t body.
HttpCacheSettings m t -> Response body -> Maybe CacheTTL
getCachableResponseTTL HttpCacheSettings m t
settings Response (PotentiallyGzipped ByteString)
resp) ((CacheTTL -> m ()) -> m ()) -> (CacheTTL -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \CacheTTL
ttl -> do
      HttpCacheSettings m t
settings.logDebug (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Write cache"
          Text -> [SeriesElem] -> Message
:# [ Key
"key" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (CacheKey -> ByteString
fromCacheKey CacheKey
key)
             , Key
"ttl" Key -> Expiration -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CacheTTL -> Expiration
fromCacheTTL CacheTTL
ttl
             ]
      let cresp :: CachedResponse
cresp = CachedResponse {$sel:response:CachedResponse :: Response (PotentiallyGzipped ByteString)
response = Response (PotentiallyGzipped ByteString)
resp, $sel:inserted:CachedResponse :: UTCTime
inserted = UTCTime
now, $sel:ttl:CachedResponse :: CacheTTL
ttl = CacheTTL
ttl}
      () -> m (Either SomeException ()) -> m ()
forall a. a -> m (Either SomeException a) -> m a
fromEx () (m (Either SomeException ()) -> m ())
-> m (Either SomeException ()) -> m ()
forall a b. (a -> b) -> a -> b
$ HttpCacheSettings m t
settings.cache.set CacheKey
key (t -> m (Either SomeException ()))
-> t -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ HttpCacheSettings m t
settings.codec.serialise CachedResponse
cresp

    Request
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
gunzipResponseBody Request
req Response (PotentiallyGzipped ByteString)
resp

  fromEx :: a -> m (Either SomeException a) -> m a
  fromEx :: forall a. a -> m (Either SomeException a) -> m a
fromEx a
a m (Either SomeException a)
f = do
    Either SomeException a
result <- m (Either SomeException a)
f
    case Either SomeException a
result of
      Left SomeException
ex -> do
        HttpCacheSettings m t
settings.logWarn (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Caching error" Text -> [SeriesElem] -> Message
:# [Key
"error" Key -> String -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex]
        a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      Right a
v -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

-- | Return a 'CacheKey' for a 'Request', if it's cacheable
--
-- A 'Request' is cacheable if all are true:
--
-- - The given predicate succeeds
-- - The method is @GET@
-- - A @Cache-Control@ header with @no-store@ is not present
--
-- If cacheable, the 'CacheKey' is built from: method, scheme, host, port, path,
-- query + any @Vary@ headers.
getCachableRequestKey
  :: HttpCacheSettings m t -> Request -> Maybe CacheKey
getCachableRequestKey :: forall (m :: * -> *) t.
HttpCacheSettings m t -> Request -> Maybe CacheKey
getCachableRequestKey HttpCacheSettings m t
settings Request
req = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HttpCacheSettings m t
settings.cacheable Request
req
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.method Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"GET"
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ CacheControl
NoStore CacheControl -> [CacheControl] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` RequestHeaders
requestHeaders.cacheControl
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not HttpCacheSettings m t
settings.shared Bool -> Bool -> Bool
|| CacheControl
Private CacheControl -> [CacheControl] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` RequestHeaders
requestHeaders.cacheControl
  CacheKey -> Maybe CacheKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CacheKey -> Maybe CacheKey) -> CacheKey -> Maybe CacheKey
forall a b. (a -> b) -> a -> b
$ (ByteString, Bool, ByteString, Int, ByteString, ByteString,
 [ByteString])
-> CacheKey
forall a. Show a => a -> CacheKey
md5CacheKey (ByteString, Bool, ByteString, Int, ByteString, ByteString,
 [ByteString])
cacheKeyAttributes
 where
  requestHeaders :: RequestHeaders
requestHeaders = Request -> RequestHeaders
getRequestHeaders Request
req

  cacheKeyAttributes :: (ByteString, Bool, ByteString, Int, ByteString, ByteString,
 [ByteString])
cacheKeyAttributes =
    ( Request -> ByteString
HTTP.method Request
req
    , Request -> Bool
HTTP.secure Request
req
    , Request -> ByteString
HTTP.host Request
req
    , Request -> Int
HTTP.port Request
req
    , Request -> ByteString
HTTP.path Request
req
    , Request -> ByteString
HTTP.queryString Request
req
    , (HeaderName -> [ByteString]) -> [HeaderName] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HeaderName -> Request -> [ByteString]
`getRequestHeader` Request
req) RequestHeaders
requestHeaders.vary
    )

-- | Return a 'CacheTTL' for a 'Response', if it's cacheable
--
-- A 'Response' is cacheable if all are true:
--
-- - A @Cache-Control@ header with @no-store@ is not present
-- - If the cache is shared (first argument), a @Cache-Control@ header with
--   @private@ is not preset
-- - The response has a cacheable status code
--
-- If cacheable, the @Cache-Control[max-age]@, @Age@, and @Expires@ response
-- headers are used to compute the 'CacheTTL'.
getCachableResponseTTL
  :: HttpCacheSettings m t -> Response body -> Maybe CacheTTL
getCachableResponseTTL :: forall (m :: * -> *) t body.
HttpCacheSettings m t -> Response body -> Maybe CacheTTL
getCachableResponseTTL HttpCacheSettings m t
settings Response body
resp = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ CacheControl
NoStore CacheControl -> [CacheControl] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ResponseHeaders
responseHeaders.cacheControl
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not HttpCacheSettings m t
settings.shared Bool -> Bool -> Bool
|| CacheControl
Private CacheControl -> [CacheControl] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ResponseHeaders
responseHeaders.cacheControl
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Status -> Bool
statusIsCacheable (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response body -> Status
forall a. Response a -> Status
HTTP.responseStatus Response body
resp
  CacheTTL -> Maybe CacheTTL
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CacheTTL -> Maybe CacheTTL) -> CacheTTL -> Maybe CacheTTL
forall a b. (a -> b) -> a -> b
$ CacheTTL -> Maybe CacheTTL -> CacheTTL
forall a. a -> Maybe a -> a
fromMaybe HttpCacheSettings m t
settings.defaultTTL (Maybe CacheTTL -> CacheTTL) -> Maybe CacheTTL -> CacheTTL
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> Maybe CacheTTL
responseHeadersToTTL ResponseHeaders
responseHeaders
 where
  responseHeaders :: ResponseHeaders
responseHeaders = Response body -> ResponseHeaders
forall body. Response body -> ResponseHeaders
getResponseHeaders Response body
resp

statusIsCacheable :: Status -> Bool
statusIsCacheable :: Status -> Bool
statusIsCacheable = (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
cacheableStatusCodes) (Int -> Bool) -> (Status -> Int) -> Status -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode

-- | As per RFC 7231
--
-- <https://stackoverflow.com/a/39406969>
cacheableStatusCodes :: [Int]
cacheableStatusCodes :: [Int]
cacheableStatusCodes =
  [ Int
200 -- OK
  , Int
203 -- Non-Authoritative Information
  , Int
204 -- No Content
  , Int
206 -- Partial Content
  , Int
300 -- Multiple Choices
  , Int
301 -- Moved Permanently
  , Int
404 -- Not Found
  , Int
405 -- Method Not Allowed
  , Int
410 -- Gone
  , Int
414 -- URI Too Long
  , Int
501 -- Not Implemented
  ]

newtype Seconds = Seconds {Seconds -> Int
unwrap :: Int}
  deriving stock (Seconds -> Seconds -> Bool
(Seconds -> Seconds -> Bool)
-> (Seconds -> Seconds -> Bool) -> Eq Seconds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Seconds -> Seconds -> Bool
== :: Seconds -> Seconds -> Bool
$c/= :: Seconds -> Seconds -> Bool
/= :: Seconds -> Seconds -> Bool
Eq)
  deriving newtype (Integer -> Seconds
Seconds -> Seconds
Seconds -> Seconds -> Seconds
(Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds)
-> (Seconds -> Seconds)
-> (Seconds -> Seconds)
-> (Integer -> Seconds)
-> Num Seconds
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Seconds -> Seconds -> Seconds
+ :: Seconds -> Seconds -> Seconds
$c- :: Seconds -> Seconds -> Seconds
- :: Seconds -> Seconds -> Seconds
$c* :: Seconds -> Seconds -> Seconds
* :: Seconds -> Seconds -> Seconds
$cnegate :: Seconds -> Seconds
negate :: Seconds -> Seconds
$cabs :: Seconds -> Seconds
abs :: Seconds -> Seconds
$csignum :: Seconds -> Seconds
signum :: Seconds -> Seconds
$cfromInteger :: Integer -> Seconds
fromInteger :: Integer -> Seconds
Num, Int -> Seconds -> ShowS
[Seconds] -> ShowS
Seconds -> String
(Int -> Seconds -> ShowS)
-> (Seconds -> String) -> ([Seconds] -> ShowS) -> Show Seconds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Seconds -> ShowS
showsPrec :: Int -> Seconds -> ShowS
$cshow :: Seconds -> String
show :: Seconds -> String
$cshowList :: [Seconds] -> ShowS
showList :: [Seconds] -> ShowS
Show, ReadPrec [Seconds]
ReadPrec Seconds
Int -> ReadS Seconds
ReadS [Seconds]
(Int -> ReadS Seconds)
-> ReadS [Seconds]
-> ReadPrec Seconds
-> ReadPrec [Seconds]
-> Read Seconds
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Seconds
readsPrec :: Int -> ReadS Seconds
$creadList :: ReadS [Seconds]
readList :: ReadS [Seconds]
$creadPrec :: ReadPrec Seconds
readPrec :: ReadPrec Seconds
$creadListPrec :: ReadPrec [Seconds]
readListPrec :: ReadPrec [Seconds]
Read)

data CacheControl
  = Private
  | NoStore
  | MaxAge Seconds
  deriving stock (CacheControl -> CacheControl -> Bool
(CacheControl -> CacheControl -> Bool)
-> (CacheControl -> CacheControl -> Bool) -> Eq CacheControl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheControl -> CacheControl -> Bool
== :: CacheControl -> CacheControl -> Bool
$c/= :: CacheControl -> CacheControl -> Bool
/= :: CacheControl -> CacheControl -> Bool
Eq, Int -> CacheControl -> ShowS
[CacheControl] -> ShowS
CacheControl -> String
(Int -> CacheControl -> ShowS)
-> (CacheControl -> String)
-> ([CacheControl] -> ShowS)
-> Show CacheControl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheControl -> ShowS
showsPrec :: Int -> CacheControl -> ShowS
$cshow :: CacheControl -> String
show :: CacheControl -> String
$cshowList :: [CacheControl] -> ShowS
showList :: [CacheControl] -> ShowS
Show)

cacheControlMaxAge :: [CacheControl] -> Maybe Seconds
cacheControlMaxAge :: [CacheControl] -> Maybe Seconds
cacheControlMaxAge = (CacheControl -> Maybe Seconds) -> [CacheControl] -> Maybe Seconds
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust ((CacheControl -> Maybe Seconds)
 -> [CacheControl] -> Maybe Seconds)
-> (CacheControl -> Maybe Seconds)
-> [CacheControl]
-> Maybe Seconds
forall a b. (a -> b) -> a -> b
$ \case
  MaxAge Seconds
s -> Seconds -> Maybe Seconds
forall a. a -> Maybe a
Just Seconds
s
  CacheControl
_ -> Maybe Seconds
forall a. Maybe a
Nothing

readCacheControl :: ByteString -> Maybe CacheControl
readCacheControl :: ByteString -> Maybe CacheControl
readCacheControl = ByteString -> Maybe CacheControl
go (ByteString -> Maybe CacheControl)
-> (ByteString -> ByteString) -> ByteString -> Maybe CacheControl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall s. FoldCase s => s -> s
CI.foldCase
 where
  go :: ByteString -> Maybe CacheControl
go = \case
    ByteString
"private" -> CacheControl -> Maybe CacheControl
forall a. a -> Maybe a
Just CacheControl
Private
    ByteString
"no-store" -> CacheControl -> Maybe CacheControl
forall a. a -> Maybe a
Just CacheControl
NoStore
    ByteString
h | Just ByteString
s <- ByteString -> ByteString -> Maybe ByteString
BS8.stripPrefix ByteString
"max-age=" ByteString
h -> Seconds -> CacheControl
MaxAge (Seconds -> CacheControl) -> Maybe Seconds -> Maybe CacheControl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Seconds
forall a. Read a => String -> Maybe a
readMay (ByteString -> String
BS8.unpack ByteString
s)
    ByteString
_ -> Maybe CacheControl
forall a. Maybe a
Nothing

getCacheControl :: HasHeaders a => a -> [CacheControl]
getCacheControl :: forall a. HasHeaders a => a -> [CacheControl]
getCacheControl = (ByteString -> Maybe CacheControl)
-> [ByteString] -> [CacheControl]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe CacheControl
readCacheControl ([ByteString] -> [CacheControl])
-> (a -> [ByteString]) -> a -> [CacheControl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> a -> [ByteString]
forall a. HasHeaders a => HeaderName -> a -> [ByteString]
getHeaderCsv HeaderName
hCacheControl

setCacheControlFrom :: Response a -> Response b -> Response b
setCacheControlFrom :: forall a b. Response a -> Response b -> Response b
setCacheControlFrom Response a
from Response b
to =
  Response b
to
    { HTTP.responseHeaders = toNonCCHeader <> fromCCHeader
    }
 where
  fromCCHeader :: ResponseHeaders
fromCCHeader = (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hCacheControl) (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Response a -> ResponseHeaders
forall a. HasHeaders a => a -> ResponseHeaders
getHeaders Response a
from
  toNonCCHeader :: ResponseHeaders
toNonCCHeader = (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
hCacheControl) (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Response b -> ResponseHeaders
forall a. HasHeaders a => a -> ResponseHeaders
getHeaders Response b
to

data RequestHeaders = RequestHeaders
  { RequestHeaders -> [CacheControl]
cacheControl :: [CacheControl]
  , RequestHeaders -> [HeaderName]
vary :: [HeaderName]
  }

getRequestHeaders :: Request -> RequestHeaders
getRequestHeaders :: Request -> RequestHeaders
getRequestHeaders Request
req =
  RequestHeaders
    { $sel:cacheControl:RequestHeaders :: [CacheControl]
cacheControl = Request -> [CacheControl]
forall a. HasHeaders a => a -> [CacheControl]
getCacheControl Request
req
    , $sel:vary:RequestHeaders :: [HeaderName]
vary = (ByteString -> HeaderName) -> [ByteString] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ([ByteString] -> [HeaderName]) -> [ByteString] -> [HeaderName]
forall a b. (a -> b) -> a -> b
$ (ByteString -> [ByteString]) -> [ByteString] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ByteString -> [ByteString]
splitHeader ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ HeaderName -> Request -> [ByteString]
getRequestHeader HeaderName
hVary Request
req
    }

data ResponseHeaders = ResponseHeaders
  { ResponseHeaders -> [CacheControl]
cacheControl :: [CacheControl]
  , ResponseHeaders -> Seconds
age :: Seconds
  -- ^ Defaults to 0 if missing
  , ResponseHeaders -> Maybe UTCTime
expires :: Maybe UTCTime
  }

getResponseHeaders :: Response body -> ResponseHeaders
getResponseHeaders :: forall body. Response body -> ResponseHeaders
getResponseHeaders Response body
resp =
  ResponseHeaders
    { $sel:cacheControl:ResponseHeaders :: [CacheControl]
cacheControl = Response body -> [CacheControl]
forall a. HasHeaders a => a -> [CacheControl]
getCacheControl Response body
resp
    , $sel:age:ResponseHeaders :: Seconds
age = Seconds -> Maybe Seconds -> Seconds
forall a. a -> Maybe a -> a
fromMaybe Seconds
0 (Maybe Seconds -> Seconds) -> Maybe Seconds -> Seconds
forall a b. (a -> b) -> a -> b
$ do
        ByteString
h <- HeaderName -> Response body -> Maybe ByteString
forall a. HasHeaders a => HeaderName -> a -> Maybe ByteString
lookupHeader HeaderName
hAge Response body
resp
        String -> Maybe Seconds
forall a. Read a => String -> Maybe a
readMay (String -> Maybe Seconds) -> String -> Maybe Seconds
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS8.unpack ByteString
h
    , $sel:expires:ResponseHeaders :: Maybe UTCTime
expires = do
        ByteString
h <- HeaderName -> Response body -> Maybe ByteString
forall a. HasHeaders a => HeaderName -> a -> Maybe ByteString
lookupHeader HeaderName
hExpires Response body
resp
        Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
httpDateFormat (String -> Maybe UTCTime) -> String -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS8.unpack ByteString
h
    }

-- | <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Date#syntax>
httpDateFormat :: String
httpDateFormat :: String
httpDateFormat = String
"%a, %d %b %Y %H:%M:%S GMT"

responseHeadersToTTL :: ResponseHeaders -> Maybe CacheTTL
responseHeadersToTTL :: ResponseHeaders -> Maybe CacheTTL
responseHeadersToTTL ResponseHeaders
hs = Int -> CacheTTL
cacheTTL (Int -> CacheTTL) -> (Seconds -> Int) -> Seconds -> CacheTTL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.unwrap) (Seconds -> CacheTTL) -> Maybe Seconds -> Maybe CacheTTL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Seconds
viaMaxAge Maybe CacheTTL -> Maybe CacheTTL -> Maybe CacheTTL
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CacheTTL
viaExpires
 where
  viaMaxAge :: Maybe Seconds
viaMaxAge = Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
subtract ResponseHeaders
hs.age (Seconds -> Seconds) -> Maybe Seconds -> Maybe Seconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CacheControl] -> Maybe Seconds
cacheControlMaxAge ResponseHeaders
hs.cacheControl
  viaExpires :: Maybe CacheTTL
viaExpires = POSIXTime -> CacheTTL
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> CacheTTL)
-> (UTCTime -> POSIXTime) -> UTCTime -> CacheTTL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> CacheTTL) -> Maybe UTCTime -> Maybe CacheTTL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponseHeaders
hs.expires