CacheSpec.hs

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

module Freckle.App.Http.CacheSpec
  ( spec
  ) where

import Prelude

import Codec.Compression.GZip qualified as GZip
import Control.Lens ((.~), (<>~))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State (StateT, execStateT)
import Data.Aeson (FromJSON, eitherDecode)
import Data.ByteString.Lazy qualified as BSL
import Data.Foldable (for_)
import Data.Function ((&))
import Data.Functor (void)
import Data.HashMap.Strict qualified as HashMap
import Data.Time (addUTCTime, getCurrentTime)
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\"}" :: String
                            , "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 BSL.ByteString
requestBodyCached ss stubs req =
  getResponseBody <$> httpCached ss (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) => BSL.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