diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,8 @@ -## [_Unreleased_](https://github.com/freckle/freckle-http/compare/v0.3.1.0...main) +## [_Unreleased_](https://github.com/freckle/freckle-http/compare/v0.4.0.0...main) + +## [v0.4.0.0](https://github.com/freckle/freckle-http/compare/v0.3.1.0...v0.4.0.0) + +- Add `HttpCacheSettings{cacheByHeaders}` ## [v0.3.1.0](https://github.com/freckle/freckle-http/compare/v0.3.0.1...v0.3.1.0) diff --git a/freckle-http.cabal b/freckle-http.cabal --- a/freckle-http.cabal +++ b/freckle-http.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-http -version: 0.3.1.0 +version: 0.4.0.0 license: MIT license-file: LICENSE maintainer: Freckle Education diff --git a/library/Freckle/App/Http/Cache.hs b/library/Freckle/App/Http/Cache.hs --- a/library/Freckle/App/Http/Cache.hs +++ b/library/Freckle/App/Http/Cache.hs @@ -45,7 +45,6 @@ , hETag , hExpires , hIfNoneMatch - , hVary ) import Network.HTTP.Types.Status (Status, statusCode) import Text.Read (readMaybe) @@ -53,6 +52,7 @@ data HttpCacheSettings m t = HttpCacheSettings { shared :: Bool , cacheable :: Request -> Bool + , cacheByHeaders :: [HeaderName] , forceTTL :: Maybe CacheTTL , defaultTTL :: CacheTTL , getCurrentTime :: m UTCTime @@ -87,11 +87,10 @@ -- 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@) +-- derived key (from URL and considering any 'cacheByHeaders' 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 @@ -199,7 +198,7 @@ -- - 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. +-- query + any 'cacheByHeaders'. getCachableRequestKey :: HttpCacheSettings m t -> Request -> Maybe CacheKey getCachableRequestKey settings req = do @@ -218,7 +217,7 @@ , HTTP.port req , HTTP.path req , HTTP.queryString req - , concatMap (`getRequestHeader` req) requestHeaders.vary + , concatMap (`getRequestHeader` req) settings.cacheByHeaders ) -- | Return a 'CacheTTL' for a 'Response', if it's cacheable @@ -302,17 +301,12 @@ fromCCHeader = filter ((== hCacheControl) . fst) $ getHeaders from toNonCCHeader = filter ((/= hCacheControl) . fst) $ getHeaders to -data RequestHeaders = RequestHeaders +newtype RequestHeaders = RequestHeaders { cacheControl :: [CacheControl] - , vary :: [HeaderName] } getRequestHeaders :: Request -> RequestHeaders -getRequestHeaders req = - RequestHeaders - { cacheControl = getCacheControl req - , vary = map CI.mk $ concatMap splitHeader $ getRequestHeader hVary req - } +getRequestHeaders req = RequestHeaders {cacheControl = getCacheControl req} data ResponseHeaders = ResponseHeaders { cacheControl :: [CacheControl] diff --git a/library/Freckle/App/Http/Cache/Memcached.hs b/library/Freckle/App/Http/Cache/Memcached.hs --- a/library/Freckle/App/Http/Cache/Memcached.hs +++ b/library/Freckle/App/Http/Cache/Memcached.hs @@ -47,6 +47,7 @@ HttpCacheSettings { shared = True , cacheable = const True + , cacheByHeaders = [] , forceTTL = Nothing , defaultTTL , getCurrentTime = liftIO getCurrentTime diff --git a/library/Freckle/App/Http/Cache/State.hs b/library/Freckle/App/Http/Cache/State.hs --- a/library/Freckle/App/Http/Cache/State.hs +++ b/library/Freckle/App/Http/Cache/State.hs @@ -56,6 +56,7 @@ HttpCacheSettings { shared = False , cacheable = const True + , cacheByHeaders = [] , forceTTL = Nothing , defaultTTL = fiveMinuteTTL , getCurrentTime = liftIO getCurrentTime diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: freckle-http -version: 0.3.1.0 +version: 0.4.0.0 maintainer: Freckle Education category: HTTP github: freckle/freckle-http diff --git a/tests/Freckle/App/Http/CacheSpec.hs b/tests/Freckle/App/Http/CacheSpec.hs --- a/tests/Freckle/App/Http/CacheSpec.hs +++ b/tests/Freckle/App/Http/CacheSpec.hs @@ -98,7 +98,7 @@ cache.map `shouldSatisfy` ((== 0) . HashMap.size) - it "incorporates Vary headers into the cache key" $ do + it "incorporates cacheByHeaders into the cache key" $ do let stubs = [ "https://example.com/1" @@ -118,31 +118,29 @@ 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" + settings' = settings {cacheByHeaders = [hAcceptLanguage]} + 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" + 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" + 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) @@ -162,21 +160,25 @@ 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 + -- User's shouldn't really need to do this, but since we've set up + -- mocks that return meaningfully-different content within the + -- gzip-or-not cases, we need to ensure they're cached separately. In + -- reality, it wouldn't matter which is cached since we always + -- correctly docompress or not based on content-encoding. + settings' = settings {cacheByHeaders = [hAcceptEncoding]} + 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 + 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)