freckle-app 1.15.0.1 → 1.15.1.0

raw patch · 13 files changed

+1130/−7 lines, 13 filesdep +hspec-expectations-jsondep +monad-loggerdep +zlibPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec-expectations-json, monad-logger, zlib

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• freckle-app.cabal +15/−2
• library/Freckle/App/Http.hs +8/−0
• library/Freckle/App/Http/Cache.hs +335/−0
• library/Freckle/App/Http/Cache/Gzip.hs +63/−0
• library/Freckle/App/Http/Cache/Memcached.hs +146/−0
• library/Freckle/App/Http/Cache/State.hs +80/−0
• library/Freckle/App/Http/Header.hs +46/−0
• library/Freckle/App/Memcached/CacheKey.hs +1/−1
• library/Freckle/App/Memcached/CacheTTL.hs +2/−1
• library/Freckle/App/Memcached/Client.hs +22/−1
• package.yaml +8/−1
• tests/Freckle/App/Http/CacheSpec.hs +398/−0

@@ -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) 

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

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

@@ -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@)+--+-- - <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 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+--+-- <https://stackoverflow.com/a/39406969>+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+    }++-- | <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Date#syntax>+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

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

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

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

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

@@ -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 =

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

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

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

@@ -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 .~ "<ignore me>\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 .~ "<ignore me>\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 "<unreachable>"+  Right a -> pure a