freckle-app-1.18.1.0: tests/Freckle/App/Http/CacheSpec.hs
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}
module Freckle.App.Http.CacheSpec
( spec
) where
import Freckle.App.Prelude
import Codec.Compression.GZip qualified as GZip
import Control.Lens ((&), (.~), (<>~))
import Control.Monad.State (StateT, execStateT)
import Data.Aeson (FromJSON, eitherDecode)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.HashMap.Strict qualified 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