diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,9 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.15.0.1...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.15.1.0...main) + +## [v1.15.1.0](https://github.com/freckle/freckle-app/compare/v1.15.0.1...v1.15.1.0) + +- Add `Freckle.App.Http.Cache` +- Add `disableRequestDecompress` ## [v1.15.0.1](https://github.com/freckle/freckle-app/compare/v1.15.0.0...v1.15.0.1) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app -version: 1.15.0.1 +version: 1.15.1.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -40,6 +40,11 @@ Freckle.App.Ghci Freckle.App.GlobalCache Freckle.App.Http + Freckle.App.Http.Cache + Freckle.App.Http.Cache.Gzip + Freckle.App.Http.Cache.Memcached + Freckle.App.Http.Cache.State + Freckle.App.Http.Header Freckle.App.Http.Paginate Freckle.App.Http.Retry Freckle.App.Json.Empty @@ -143,6 +148,7 @@ lens >=5.1.1, memcache >=0.3.0.1, monad-control >=1.0.3.1, + monad-logger >=0.3.40, monad-logger-aeson >=0.4.0.4, monad-validate >=1.3.0.0, mtl >=2.2.2, @@ -224,6 +230,7 @@ Freckle.App.Bugsnag.MetaDataSpec Freckle.App.BugsnagSpec Freckle.App.CsvSpec + Freckle.App.Http.CacheSpec Freckle.App.HttpSpec Freckle.App.Memcached.ServersSpec Freckle.App.MemcachedSpec @@ -264,17 +271,23 @@ errors >=2.3.0, freckle-app, hspec >=2.9.7, + hspec-expectations-json >=1.0.0.7, + hspec-expectations-lifted >=0.10.0, http-types >=0.12.3, lens >=5.1.1, lens-aeson >=1.2.2, memcache >=0.3.0.1, monad-validate >=1.3.0.0, + mtl >=2.2.2, nonempty-containers >=0.3.4.4, postgresql-simple >=0.6.4, text >=1.2.5.0, + time >=1.11.1.1, + unordered-containers >=0.2.19.1, vector >=0.12.3.1, wai >=3.2.3, - wai-extra >=3.1.13.0 + wai-extra >=3.1.13.0, + zlib >=0.6.3.0 if impl(ghc >=9.8) ghc-options: -Wno-missing-role-annotations diff --git a/library/Freckle/App/Http.hs b/library/Freckle/App/Http.hs --- a/library/Freckle/App/Http.hs +++ b/library/Freckle/App/Http.hs @@ -33,6 +33,7 @@ , setRequestBodyURLEncoded , setRequestCheckStatus , setRequestPath + , disableRequestDecompress -- * Response accessors , Response @@ -88,6 +89,7 @@ import qualified Data.List.NonEmpty as NE import Freckle.App.Http.Paginate import Freckle.App.Http.Retry +import qualified Network.HTTP.Client as HTTP (Request (..)) import Network.HTTP.Conduit (HttpExceptionContent (..)) import Network.HTTP.Simple hiding (httpLbs, httpNoBody) import qualified Network.HTTP.Simple as HTTP @@ -248,6 +250,12 @@ addBearerAuthorizationHeader :: BS.ByteString -> Request -> Request addBearerAuthorizationHeader = addRequestHeader hAuthorization . ("Bearer " <>) + +disableRequestDecompress :: Request -> Request +disableRequestDecompress req = + req + { HTTP.decompress = const False + } -- | Read an 'Either' response body, throwing any 'Left' as an exception -- diff --git a/library/Freckle/App/Http/Cache.hs b/library/Freckle/App/Http/Cache.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache.hs @@ -0,0 +1,335 @@ +{-# 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 qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import qualified Data.CaseInsensitive 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 qualified Network.HTTP.Client 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 + { shared :: Bool + , cacheable :: Request -> Bool + , defaultTTL :: CacheTTL + , getCurrentTime :: m UTCTime + , logDebug :: Message -> m () + , logWarn :: Message -> m () + , codec :: HttpCacheCodec t + , cache :: HttpCache m t + } + +data HttpCacheCodec t = HttpCacheCodec + { serialise :: CachedResponse -> t + , deserialise :: Request -> t -> Either String CachedResponse + } + +data HttpCache m t = HttpCache + { get :: CacheKey -> m (Either SomeException (Maybe t)) + , set :: CacheKey -> t -> m (Either SomeException ()) + , evict :: CacheKey -> m (Either SomeException ()) + } + +data CachedResponse = CachedResponse + { response :: Response (PotentiallyGzipped BSL.ByteString) + , inserted :: UTCTime + , ttl :: CacheTTL + } + deriving stock (Show) + +isCachedResponseStale :: CachedResponse -> UTCTime -> Bool +isCachedResponseStale cached now = + addUTCTime (fromIntegral cached.ttl) cached.inserted < 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@) +-- +-- - +-- - +-- +-- 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. +-- +-- - +-- +httpCached + :: forall m t + . MonadIO m + => HttpCacheSettings m t + -> (Request -> m (Response BSL.ByteString)) + -> Request + -> m (Response BSL.ByteString) +httpCached settings doHttp req = + maybe (doHttp req) handleCachableRequest $ getCachableRequestKey settings req + where + handleCachableRequest key = do + now <- settings.getCurrentTime + result <- fromEx Nothing $ settings.cache.get key + + let tkey = decodeUtf8With lenientDecode $ fromCacheKey key + + case result of + Nothing -> do + settings.logDebug $ "Cache miss" :# ["key" .= tkey] + writeCache now key =<< getResponse req + Just val -> do + settings.logDebug $ "Cache hit" :# ["key" .= tkey] + case settings.codec.deserialise req val of + Left err -> do + settings.logWarn $ "Error deserialising" :# ["error" .= err] + writeCache now key =<< getResponse req + Right cresp | isCachedResponseStale cresp now -> do + settings.logDebug $ + "Cached value stale" + :# [ "key" .= tkey + , "inserted" .= cresp.inserted + , "ttl" .= fromCacheTTL cresp.ttl + , "now" .= now + ] + case lookupHeader hETag cresp.response of + Nothing -> do + fromEx () $ settings.cache.evict key + writeCache now key =<< getResponse req + Just etag -> do + settings.logDebug $ + "Retrying with If-None-Match" + :# [ "key" .= tkey + , "etag" .= decodeUtf8With lenientDecode etag + ] + resp <- getResponse $ addRequestHeader hIfNoneMatch etag req + case statusCode (getResponseStatus resp) of + 304 -> do + settings.logDebug "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 + writeCache now key $ setCacheControlFrom resp cresp.response + _ -> do + settings.logDebug "ETag not matched, evicting cache" + fromEx () $ settings.cache.evict key + writeCache now key resp + Right cresp -> gunzipResponseBody req cresp.response + + getResponse :: Request -> m (Response (PotentiallyGzipped BSL.ByteString)) + getResponse = requestPotentiallyGzipped doHttp + + writeCache + :: UTCTime + -> CacheKey + -> Response (PotentiallyGzipped BSL.ByteString) + -> m (Response BSL.ByteString) + writeCache now key resp = do + for_ (getCachableResponseTTL settings resp) $ \ttl -> do + settings.logDebug $ + "Write cache" + :# [ "key" .= decodeUtf8With lenientDecode (fromCacheKey key) + , "ttl" .= fromCacheTTL ttl + ] + let cresp = CachedResponse {response = resp, inserted = now, ttl = ttl} + fromEx () $ settings.cache.set key $ settings.codec.serialise cresp + + gunzipResponseBody req resp + + fromEx :: a -> m (Either SomeException a) -> m a + fromEx a f = do + result <- f + case result of + Left ex -> do + settings.logWarn $ "Caching error" :# ["error" .= displayException ex] + pure a + Right v -> pure 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 settings req = do + guard $ settings.cacheable req + guard $ HTTP.method req == "GET" + guard $ NoStore `notElem` requestHeaders.cacheControl + guard $ not settings.shared || Private `notElem` requestHeaders.cacheControl + pure $ md5CacheKey cacheKeyAttributes + where + requestHeaders = getRequestHeaders req + + cacheKeyAttributes = + ( HTTP.method req + , HTTP.secure req + , HTTP.host req + , HTTP.port req + , HTTP.path req + , HTTP.queryString req + , concatMap (`getRequestHeader` req) 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 settings resp = do + guard $ NoStore `notElem` responseHeaders.cacheControl + guard $ not settings.shared || Private `notElem` responseHeaders.cacheControl + guard $ statusIsCacheable $ HTTP.responseStatus resp + pure $ fromMaybe settings.defaultTTL $ responseHeadersToTTL responseHeaders + where + responseHeaders = getResponseHeaders resp + +statusIsCacheable :: Status -> Bool +statusIsCacheable = (`elem` cacheableStatusCodes) . statusCode + +-- | As per RFC 7231 +-- +-- +cacheableStatusCodes :: [Int] +cacheableStatusCodes = + [ 200 -- OK + , 203 -- Non-Authoritative Information + , 204 -- No Content + , 206 -- Partial Content + , 300 -- Multiple Choices + , 301 -- Moved Permanently + , 404 -- Not Found + , 405 -- Method Not Allowed + , 410 -- Gone + , 414 -- URI Too Long + , 501 -- Not Implemented + ] + +newtype Seconds = Seconds {unwrap :: Int} + deriving stock (Eq) + deriving newtype (Num, Show, Read) + +data CacheControl + = Private + | NoStore + | MaxAge Seconds + deriving stock (Eq, Show) + +cacheControlMaxAge :: [CacheControl] -> Maybe Seconds +cacheControlMaxAge = firstJust $ \case + MaxAge s -> Just s + _ -> Nothing + +readCacheControl :: ByteString -> Maybe CacheControl +readCacheControl = go . CI.foldCase + where + go = \case + "private" -> Just Private + "no-store" -> Just NoStore + h | Just s <- BS8.stripPrefix "max-age=" h -> MaxAge <$> readMay (BS8.unpack s) + _ -> Nothing + +getCacheControl :: HasHeaders a => a -> [CacheControl] +getCacheControl = mapMaybe readCacheControl . getHeaderCsv hCacheControl + +setCacheControlFrom :: Response a -> Response b -> Response b +setCacheControlFrom from to = + to + { HTTP.responseHeaders = toNonCCHeader <> fromCCHeader + } + where + fromCCHeader = filter ((== hCacheControl) . fst) $ getHeaders from + toNonCCHeader = filter ((/= hCacheControl) . fst) $ getHeaders to + +data RequestHeaders = RequestHeaders + { cacheControl :: [CacheControl] + , vary :: [HeaderName] + } + +getRequestHeaders :: Request -> RequestHeaders +getRequestHeaders req = + RequestHeaders + { cacheControl = getCacheControl req + , vary = map CI.mk $ concatMap splitHeader $ getRequestHeader hVary req + } + +data ResponseHeaders = ResponseHeaders + { cacheControl :: [CacheControl] + , age :: Seconds + -- ^ Defaults to 0 if missing + , expires :: Maybe UTCTime + } + +getResponseHeaders :: Response body -> ResponseHeaders +getResponseHeaders resp = + ResponseHeaders + { cacheControl = getCacheControl resp + , age = fromMaybe 0 $ do + h <- lookupHeader hAge resp + readMay $ BS8.unpack h + , expires = do + h <- lookupHeader hExpires resp + parseTimeM True defaultTimeLocale httpDateFormat $ BS8.unpack h + } + +-- | +httpDateFormat :: String +httpDateFormat = "%a, %d %b %Y %H:%M:%S GMT" + +responseHeadersToTTL :: ResponseHeaders -> Maybe CacheTTL +responseHeadersToTTL hs = cacheTTL . (.unwrap) <$> viaMaxAge <|> viaExpires + where + viaMaxAge = subtract hs.age <$> cacheControlMaxAge hs.cacheControl + viaExpires = round . utcTimeToPOSIXSeconds <$> hs.expires diff --git a/library/Freckle/App/Http/Cache/Gzip.hs b/library/Freckle/App/Http/Cache/Gzip.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache/Gzip.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} + +-- | Type and functions for handling gzipped HTTP responses +-- +-- In order to optimize caching of responses in storage with size limitations, +-- we cache gzipped responses as-is. This requires disabling the automatic +-- decompression of @http-client@ and handling it ourselves. +-- +-- The module makes that a type-enforced process: +-- +-- - 'requestPotentiallyGzipped' is the only way to get a 'PotentiallyGzipped' +-- - Which is the type needed for the response field in 'CachedResponse' +-- - 'gunzipResponseBody' is the only way to erase 'PotentiallyGzipped' +-- - Which is what you actually need to return +module Freckle.App.Http.Cache.Gzip + ( PotentiallyGzipped + , requestPotentiallyGzipped + , gunzipResponseBody + ) where + +import Freckle.App.Prelude + +import Codec.Serialise (Serialise) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BSL +import Freckle.App.Http (disableRequestDecompress) +import Freckle.App.Http.Header +import Network.HTTP.Client (Request, Response) +import qualified Network.HTTP.Client.Internal as HTTP + +newtype PotentiallyGzipped a = PotentiallyGzipped + { unwrap :: a + } + deriving stock (Show, Eq) + deriving newtype (Serialise) + +-- | Run a request /without/ automatic 'decompress' and tag the @body@ type +requestPotentiallyGzipped + :: Functor m + => (Request -> m (Response body)) + -> Request + -> m (Response (PotentiallyGzipped body)) +requestPotentiallyGzipped doHttp = + fmap (fmap PotentiallyGzipped) . doHttp . disableRequestDecompress + +-- | Gunzip a 'PotentiallyGzipped' body, if necessary +gunzipResponseBody + :: MonadIO m + => Request + -> Response (PotentiallyGzipped ByteString) + -> m (Response ByteString) +gunzipResponseBody req resp + | HTTP.needsGunzip req (getHeaders resp) = liftIO $ do + body <- gunzipBody $ HTTP.responseBody resp + pure $ body <$ resp + | otherwise = pure $ (.unwrap) <$> resp + +gunzipBody :: PotentiallyGzipped ByteString -> IO ByteString +gunzipBody body = do + body1 <- HTTP.constBodyReader $ BSL.toChunks body.unwrap + reader <- HTTP.makeGzipReader body1 + BSL.fromChunks <$> HTTP.brConsume reader diff --git a/library/Freckle/App/Http/Cache/Memcached.hs b/library/Freckle/App/Http/Cache/Memcached.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache/Memcached.hs @@ -0,0 +1,146 @@ +{-# 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 defaultTTL = + HttpCacheSettings + { shared = True + , cacheable = const True + , defaultTTL + , getCurrentTime = liftIO getCurrentTime + , logDebug = logDebugNS "http.cache" + , logWarn = logWarnNS "http.cache" + , codec = memcachedHttpCodec + , cache = memcachedHttpCache + } + +memcachedHttpCodec :: HttpCacheCodec Value +memcachedHttpCodec = + HttpCacheCodec + { serialise = BSL.toStrict . serialise . fromResponse + , deserialise = \req -> + bimap show (toResponse req) + . deserialiseOrFail + . BSL.fromStrict + } + +memcachedHttpCache + :: ( MonadUnliftIO m + , MonadTracer m + , MonadReader env m + , HasMemcachedClient env + ) + => HttpCache m Value +memcachedHttpCache = + HttpCache + { get = try . Memcached.get + , set = \k v -> try $ Memcached.set k v 0 + , evict = try . 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 + { sresponseStatus :: Status + , sresponseVersion :: HttpVersion + , sresponseHeaders :: ResponseHeaders + , sresponseBody :: PotentiallyGzipped BSL.ByteString + , sresponseEarlyHints :: ResponseHeaders + , sinserted :: UTCTime + , sttl :: CacheTTL + } + deriving stock (Generic) + deriving anyclass (Serialise) + +{- FOURMOLU_DISABLE -} +-- Fourmolu has trouble with this bit of CPP + +toResponse :: Request -> SerialiseResponse -> CachedResponse +toResponse req c = CachedResponse + { response = HTTP.Response + { HTTP.responseStatus = sresponseStatus c + , HTTP.responseVersion = sresponseVersion c + , HTTP.responseHeaders = sresponseHeaders c + , HTTP.responseBody = sresponseBody c + , HTTP.responseCookieJar = mempty + , HTTP.responseClose' = HTTP.ResponseClose (pure ()) + , HTTP.responseOriginalRequest = req +#if MIN_VERSION_http_client(0,7,16) + , HTTP.responseEarlyHints = sresponseEarlyHints c +#endif + } + , inserted = c.sinserted + , ttl = c.sttl + } + +fromResponse :: CachedResponse -> SerialiseResponse +fromResponse cr = + SerialiseResponse + { sresponseStatus = HTTP.responseStatus r + , sresponseVersion = HTTP.responseVersion r + , sresponseHeaders = HTTP.responseHeaders r + , sresponseBody = HTTP.responseBody r +#if MIN_VERSION_http_client(0,7,16) + , sresponseEarlyHints = HTTP.responseEarlyHints r +#else + , sresponseEarlyHints = [] +#endif + , sinserted = cr.inserted + , sttl = cr.ttl + } + where + r = 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 = encode . CI.original + decode = CI.mk <$> decode diff --git a/library/Freckle/App/Http/Cache/State.hs b/library/Freckle/App/Http/Cache/State.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache/State.hs @@ -0,0 +1,80 @@ +{-# 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 + { map :: HashMap CacheKey CachedResponse + } + deriving newtype (Semigroup, Monoid) + +mapL :: Lens' Cache (HashMap CacheKey CachedResponse) +mapL = lens (.map) $ \x y -> x {map = y} + +class HasCache env where + cacheL :: Lens' env Cache + +instance HasCache Cache where + cacheL = id + +stateHttpCacheSettings + :: ( MonadIO m + , MonadState s m + , HasCache s + ) + => HttpCacheSettings m CachedResponse +stateHttpCacheSettings = + HttpCacheSettings + { shared = False + , cacheable = const True + , defaultTTL = fiveMinuteTTL + , getCurrentTime = liftIO getCurrentTime + , logDebug = \_ -> pure () + , logWarn = liftIO . T.hPutStrLn stderr . messageToText + , codec = stateHttpCacheCodec + , cache = stateHttpCache + } + +stateHttpCacheCodec :: HttpCacheCodec CachedResponse +stateHttpCacheCodec = + HttpCacheCodec + { serialise = id + , deserialise = const Right + } + +stateHttpCache + :: (MonadIO m, MonadState s m, HasCache s) => HttpCache m CachedResponse +stateHttpCache = + HttpCache + { get = \key -> fmap Right $ use $ cacheL . mapL . at key + , set = \key resp -> fmap Right $ cacheL . mapL . at key ?= resp + , evict = \key -> fmap Right $ cacheL . mapL . at key .= Nothing + } + +messageToText :: Message -> Text +messageToText = decodeUtf8With lenientDecode . fromLogStr . toLogStr diff --git a/library/Freckle/App/Http/Header.hs b/library/Freckle/App/Http/Header.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Header.hs @@ -0,0 +1,46 @@ +module Freckle.App.Http.Header + ( HasHeaders (..) + , getHeaderCsv + , lookupHeader + + -- * Utilities + , splitHeader + ) where + +import Freckle.App.Prelude + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (isSpace) +import Network.HTTP.Client (Request, Response, requestHeaders, responseHeaders) +import Network.HTTP.Simple (getRequestHeader, getResponseHeader) +import Network.HTTP.Types.Header (Header, HeaderName) + +class HasHeaders a where + getHeaders :: a -> [Header] + + getHeader :: HeaderName -> a -> [ByteString] + getHeader h = map snd . filter ((== h) . fst) . getHeaders + +instance HasHeaders [Header] where + getHeaders = id + +instance HasHeaders Request where + getHeaders = requestHeaders + getHeader = getRequestHeader + +instance HasHeaders (Response body) where + getHeaders = responseHeaders + getHeader = getResponseHeader + +getHeaderCsv :: HasHeaders a => HeaderName -> a -> [ByteString] +getHeaderCsv hn = concatMap splitHeader . getHeader hn + +splitHeader :: ByteString -> [ByteString] +splitHeader = map trimSpace . BS8.split ',' + +trimSpace :: ByteString -> ByteString +trimSpace = BS8.dropWhile isSpace . BS8.dropWhileEnd isSpace + +lookupHeader :: HasHeaders a => HeaderName -> a -> Maybe ByteString +lookupHeader h = listToMaybe . getHeader h diff --git a/library/Freckle/App/Memcached/CacheKey.hs b/library/Freckle/App/Memcached/CacheKey.hs --- a/library/Freckle/App/Memcached/CacheKey.hs +++ b/library/Freckle/App/Memcached/CacheKey.hs @@ -35,7 +35,7 @@ cacheKey t | T.length t > 250 = invalid "Must be fewer than 250 characters" | T.any isControl t = invalid "Cannot contain control characters" - | T.any isSpace t = invalid "Cannot container whitespace" + | T.any isSpace t = invalid "Cannot contain whitespace" | otherwise = Right $ CacheKey t where invalid msg = diff --git a/library/Freckle/App/Memcached/CacheTTL.hs b/library/Freckle/App/Memcached/CacheTTL.hs --- a/library/Freckle/App/Memcached/CacheTTL.hs +++ b/library/Freckle/App/Memcached/CacheTTL.hs @@ -7,13 +7,14 @@ import Freckle.App.Prelude +import Codec.Serialise (Serialise (..)) import Data.Word (Word32) import Database.Memcache.Types (Expiration) import OpenTelemetry.Trace (ToAttribute (..)) newtype CacheTTL = CacheTTL Int deriving stock (Show) - deriving newtype (Eq, Ord, Enum, Num, Real, Integral) + deriving newtype (Eq, Ord, Enum, Num, Real, Integral, Serialise) instance ToAttribute CacheTTL where toAttribute (CacheTTL x) = toAttribute x diff --git a/library/Freckle/App/Memcached/Client.hs b/library/Freckle/App/Memcached/Client.hs --- a/library/Freckle/App/Memcached/Client.hs +++ b/library/Freckle/App/Memcached/Client.hs @@ -6,6 +6,7 @@ , HasMemcachedClient (..) , get , set + , delete ) where import Freckle.App.Prelude @@ -13,7 +14,7 @@ import Control.Lens (Lens', view, _1) import qualified Data.HashMap.Strict as HashMap import qualified Database.Memcache.Client as Memcache -import Database.Memcache.Types (Value) +import Database.Memcache.Types (Value, Version) import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL import Freckle.App.Memcached.Servers @@ -100,6 +101,22 @@ ] } +-- | Delete a key +delete + :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env) + => CacheKey + -> m () +delete k = traced $ with $ \case + MemcachedClient mc -> void $ liftIO $ Memcache.delete mc (fromCacheKey k) bypassCAS + MemcachedClientDisabled -> pure () + where + traced = + inSpan + "cache.delete" + clientSpanArguments + { Trace.attributes = HashMap.fromList [("key", Trace.toAttribute k)] + } + quitClient :: MonadIO m => MemcachedClient -> m () quitClient = \case MemcachedClient mc -> void $ liftIO $ Memcache.quit mc @@ -112,3 +129,7 @@ with f = do c <- view memcachedClientL f c + +-- | The sentinal version @0@ means to not perform CAS checking +bypassCAS :: Version +bypassCAS = 0 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: freckle-app -version: 1.15.0.1 +version: 1.15.1.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app @@ -116,6 +116,7 @@ - lens - memcache - monad-control + - monad-logger - monad-logger-aeson - monad-validate - mtl @@ -167,17 +168,23 @@ - errors - freckle-app - hspec + - hspec-expectations-json + - hspec-expectations-lifted - http-types - lens - lens-aeson - memcache - monad-validate + - mtl - nonempty-containers - postgresql-simple - text + - time + - unordered-containers - vector - wai - wai-extra + - zlib doctest: main: Main.hs diff --git a/tests/Freckle/App/Http/CacheSpec.hs b/tests/Freckle/App/Http/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/Http/CacheSpec.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Freckle.App.Http.CacheSpec + ( spec + ) where + +import Freckle.App.Prelude + +import qualified Codec.Compression.GZip as GZip +import Control.Lens ((&), (.~), (<>~)) +import Control.Monad.State (StateT, execStateT) +import Data.Aeson (FromJSON, eitherDecode) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as HashMap +import Data.Time (addUTCTime) +import Freckle.App.Http +import Freckle.App.Http.Cache +import Freckle.App.Http.Cache.State +import Freckle.App.Test.Http +import Network.HTTP.Types.Header + ( hAcceptEncoding + , hAcceptLanguage + , hAge + , hCacheControl + , hContentEncoding + , hETag + , hExpires + , hIfNoneMatch + , hVary + ) +import Network.HTTP.Types.Status + ( status100 + , status304 + , status307 + , status400 + , status503 + ) +import Test.Hspec (Spec, context, describe, it) +import Test.Hspec.Expectations.Json.Lifted (shouldMatchJson) +import Test.Hspec.Expectations.Lifted + +type CacheSettings = HttpCacheSettings (StateT Cache IO) CachedResponse + +spec :: Spec +spec = do + describe "httpCached" $ do + it "caches successful GET requests" $ do + let + stubs = + [ "https://example.com/1" & bodyL .~ "Hello\n" + , "https://example.com/2" & bodyL .~ "World\n" + ] + + req1 = parseRequest_ "https://example.com/1" + req2 = parseRequest_ "https://example.com/2" + + cache <- execCached $ do + requestBodyCached settings stubs req1 `shouldReturn` "Hello\n" + requestBodyCached settings stubs req2 `shouldReturn` "World\n" + + -- No stubs, so these would fail if not cached + requestBodyCached settings [] req1 `shouldReturn` "Hello\n" + requestBodyCached settings [] req2 `shouldReturn` "World\n" + + cache.map `shouldSatisfy` ((== 2) . HashMap.size) + + it "evicts stale caches" $ do + let + stubs = + [ "https://example.com/1" + & headersL <>~ [(hCacheControl, "max-age=2")] + & bodyL .~ "Hi\n" + ] + + -- On the request that we expect to evict, we'll use this so that we + -- don't store a cache from that and we can observe the eviction. + stubsNoStore = + [ "https://example.com/1" + & headersL <>~ [(hCacheControl, "no-store")] + & bodyL .~ "Hi\n" + ] + + req = parseRequest_ "https://example.com/1" + + cache <- execCached $ do + requestBodyCached settings stubs req `shouldReturn` "Hi\n" + + -- Cached, no requests made + requestBodyCached settings [] req `shouldReturn` "Hi\n" + + -- Expired, trigger eviction + requestBodyCached settingsFuture stubsNoStore req `shouldReturn` "Hi\n" + + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + it "incorporates Vary headers into the cache key" $ do + let + stubs = + [ "https://example.com/1" + & matchL <>~ MatchHeader (hAcceptLanguage, "en") + & bodyL .~ "Hello\n" + , "https://example.com/1" + & matchL <>~ MatchHeader (hAcceptLanguage, "es") + & bodyL .~ "Hola\n" + , "https://example.com/2" + & matchL <>~ MatchHeader (hAcceptLanguage, "en") + & bodyL .~ "World\n" + , "https://example.com/2" + & matchL <>~ MatchHeader (hAcceptLanguage, "es") + & bodyL .~ "Mundo\n" + ] + + reqEn1 = + parseRequest_ "https://example.com/1" + & addRequestHeader hAcceptLanguage "en" + & addRequestHeader hVary "Accept, Accept-Language" + reqEn2 = + parseRequest_ "https://example.com/2" + & addRequestHeader hAcceptLanguage "en" + & addRequestHeader hVary "Accept, Accept-Language" + reqEs1 = + parseRequest_ "https://example.com/1" + & addRequestHeader hAcceptLanguage "es" + & addRequestHeader hVary "Accept, Accept-Language" + reqEs2 = + parseRequest_ "https://example.com/2" + & addRequestHeader hAcceptLanguage "es" + & addRequestHeader hVary "Accept, Accept-Language" + + cache <- execCached $ do + requestBodyCached settings stubs reqEn1 `shouldReturn` "Hello\n" + requestBodyCached settings stubs reqEn2 `shouldReturn` "World\n" + requestBodyCached settings stubs reqEs1 `shouldReturn` "Hola\n" + requestBodyCached settings stubs reqEs2 `shouldReturn` "Mundo\n" + + -- No stubs, so these would fail if not cached + requestBodyCached settings [] reqEn1 `shouldReturn` "Hello\n" + requestBodyCached settings [] reqEn2 `shouldReturn` "World\n" + requestBodyCached settings [] reqEs1 `shouldReturn` "Hola\n" + requestBodyCached settings [] reqEs2 `shouldReturn` "Mundo\n" + + cache.map `shouldSatisfy` ((== 4) . HashMap.size) + + context "compression" $ do + it "caches gzipped responses as gzipped" $ do + let + gzipped = GZip.compress "Hi (zipped)\n" + + stubs = + [ "https://example.com/1" + & matchL <>~ MatchHeader (hAcceptEncoding, "gzip") + & headersL <>~ [(hContentEncoding, "gzip")] + & bodyL .~ gzipped + , "https://example.com/1" + & bodyL .~ "Hi (not zipped)\n" + ] + + req = + parseRequest_ "https://example.com/1" + & addRequestHeader hVary "accept-encoding" + reqGzipped = + parseRequest_ "https://example.com/1" + & addRequestHeader hVary "accept-encoding" + & addRequestHeader hAcceptEncoding "gzip" + reqGzippedAsIs = + parseRequest_ "https://example.com/1" + & addRequestHeader hVary "accept-encoding" + & addRequestHeader hAcceptEncoding "gzip" + & disableRequestDecompress + + cache <- execCached $ do + requestBodyCached settings stubs req `shouldReturn` "Hi (not zipped)\n" + requestBodyCached settings stubs reqGzipped `shouldReturn` "Hi (zipped)\n" + requestBodyCached settings stubs reqGzippedAsIs `shouldReturn` gzipped + + cache.map `shouldSatisfy` ((== 2) . HashMap.size) + + -- We don't want to expose the constructor, but we do want to verify the + -- cache contains the gzipped form. + map (show . getResponseBody . (.response) . snd) (HashMap.toList cache.map) + `shouldMatchList` [ "PotentiallyGzipped {unwrap = \"Hi (not zipped)\\n\"}" + , "PotentiallyGzipped {unwrap = " <> show gzipped <> "}" + ] + + it "handles large gzip responses correctly" $ do + bs <- BSL.readFile "tests/files/constructed-responses.gzip" + val <- expectDecode $ GZip.decompress bs + + let + stubs = + [ "https://example.com/1" + & matchL <>~ MatchHeader (hAcceptEncoding, "gzip") + & headersL <>~ [(hContentEncoding, "gzip")] + & bodyL .~ bs + ] + + req = + parseRequest_ "https://example.com/1" + & addRequestHeader hVary "accept-encoding" + & addRequestHeader hAcceptEncoding "gzip" + + void $ execCached $ do + actual <- expectDecode =<< requestBodyCached settings stubs req + actual `shouldMatchJson` val + + context "Handling ETag" $ do + let etag = "W/\"99\"" + + it "uses cached response and doesn't evict on 304 from If-None-Match" $ do + let stubs = + [ "https://example.com/1" + & matchL <>~ MatchHeader (hIfNoneMatch, etag) + & statusL .~ status304 + & bodyL .~ "\n" + , "https://example.com/1" + & headersL <>~ [(hCacheControl, "max-age=-1")] + & headersL <>~ [(hETag, etag)] + & bodyL .~ "Original body\n" + ] + + cache <- execCached $ do + let req = parseRequest_ "https://example.com/1" + requestBodyCached settings stubs req `shouldReturn` "Original body\n" + requestBodyCached settings stubs req `shouldReturn` "Original body\n" + + cache.map `shouldSatisfy` ((== 1) . HashMap.size) + + it "updates cached response on 304 from If-None-Match" $ do + let stubs = + [ "https://example.com/1" + & matchL <>~ MatchHeader (hIfNoneMatch, etag) + & statusL .~ status304 + & headersL <>~ [(hCacheControl, "max-age=120")] + & bodyL .~ "\n" + , "https://example.com/1" + & headersL <>~ [(hCacheControl, "max-age=-1")] + & headersL <>~ [(hETag, etag)] + & bodyL .~ "Original body\n" + ] + + cache <- execCached $ do + let req = parseRequest_ "https://example.com/1" + requestBodyCached settings stubs req `shouldReturn` "Original body\n" + requestBodyCached settings stubs req `shouldReturn` "Original body\n" + + cache.map `shouldSatisfy` ((== 1) . HashMap.size) + map (.ttl) (HashMap.elems cache.map) `shouldBe` [120] + + it "evicts a stale response after trying If-None-Match" $ do + let stubs = + [ "https://example.com/1" + & matchL <>~ MatchHeader (hIfNoneMatch, etag) + & headersL <>~ [(hCacheControl, "no-store")] + & bodyL .~ "Newer body\n" + , "https://example.com/1" + & headersL <>~ [(hCacheControl, "max-age=-1")] + & headersL <>~ [(hETag, etag)] + & bodyL .~ "Original body\n" + ] + + cache <- execCached $ do + let req = parseRequest_ "https://example.com/1" + requestBodyCached settings stubs req `shouldReturn` "Original body\n" + requestBodyCached settings stubs req `shouldReturn` "Newer body\n" + + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + context "setting TTL" $ do + let req = parseRequest_ "https://example.com" + + it "sets TTL based on max-age" $ do + let stubs = + [ "https://example.com" + & headersL <>~ [(hCacheControl, "max-age=42")] + ] + + cache <- execCached $ requestBodyCached settings stubs req + map (.ttl) (HashMap.elems cache.map) `shouldBe` [42] + + it "sets TTL based on max-age + Age" $ do + let stubs = + [ "https://example.com" + & headersL <>~ [(hAge, "78000"), (hCacheControl, "max-age=78250")] + ] + + cache <- execCached $ requestBodyCached settings stubs req + map (.ttl) (HashMap.elems cache.map) `shouldBe` [250] + + it "sets TTL based on Expires" $ do + let + expDate = "Wed, 21 Oct 2015 07:28:00 GMT" + expSeconds = 1445412480 -- `date --date '{eDate}' +%s` + stubs = ["https://example.com" & headersL <>~ [(hExpires, expDate)]] + + cache <- execCached $ requestBodyCached settings stubs req + map (.ttl) (HashMap.elems cache.map) `shouldBe` [expSeconds] + + context "un-cacheable requests" $ do + it "does not cache if told not to" $ do + let req = parseRequest_ "https://example.com" + cache <- execCached $ requestBodyCached settingsDisabled stubAnything req + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + it "does not cache non-GET methods" $ do + let req = parseRequest_ "POST https://example.com" + cache <- execCached $ requestBodyCached settings stubAnything req + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + it "does not cache no-store" $ do + let req = + parseRequest_ "https://example.com" + & addRequestHeader hCacheControl "no-store" + cache <- execCached $ requestBodyCached settings stubAnything req + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + it "does not cache private in a shared cache" $ do + let req = + parseRequest_ "https://example.com" + & addRequestHeader hCacheControl "private" + cache <- execCached $ requestBodyCached settingsShared stubAnything req + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + context "un-cacheable responses" $ do + let req = parseRequest_ "https://example.com" + + it "does not cache no-store" $ do + let stubs = + [ "https://example.com" + & headersL <>~ [(hCacheControl, "no-store, max-age=0, public")] + ] + + cache <- execCached $ requestBodyCached settings stubs req + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + it "does not cache private in a shared cache" $ do + let stubs = + [ "https://example.com" + & headersL <>~ [(hCacheControl, "max-age=0, private")] + ] + + cache <- execCached $ requestBodyCached settingsShared stubs req + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + + for_ [status100, status307, status400, status503] $ \s -> do + it ("does not cache un-cacheable status " <> show (statusCode s)) $ do + let stubs = ["https://example.com" & statusL .~ s] + + cache <- execCached $ requestBodyCached settingsShared stubs req + cache.map `shouldSatisfy` ((== 0) . HashMap.size) + +execCached :: StateT Cache IO a -> IO Cache +execCached = flip execStateT mempty + +requestBodyCached + :: CacheSettings + -> [HttpStub] + -> Request + -> StateT Cache IO ByteString +requestBodyCached ss stubs req = + getResponseBody <$> httpCached ss (pure . httpStubbed stubs) req + +settings :: CacheSettings +settings = stateHttpCacheSettings + +settingsDisabled :: CacheSettings +settingsDisabled = + settings + { cacheable = const False + } + +settingsShared :: CacheSettings +settingsShared = + settings + { shared = True + } + +settingsFuture :: CacheSettings +settingsFuture = + settings + { getCurrentTime = liftIO $ addUTCTime 5 <$> getCurrentTime + } + +stubAnything :: [HttpStub] +stubAnything = [httpStub "Anything" MatchAnything] + +expectDecode :: (HasCallStack, MonadIO m, FromJSON a) => ByteString -> m a +expectDecode bs = case eitherDecode bs of + Left err -> do + expectationFailure $ + mconcat + [ "Expected input to decode as JSON" + , "\nInput: " <> show bs + , "\nErrors: " <> err + ] + error "" + Right a -> pure a