test: move jwt cache tests from io tests to spec tests

Signed-off-by: Taimoor Zaeem <taimoorzaeem@gmail.com>

test/spec/Feature/Auth/JwtCacheSpec.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE BangPatterns #-}
+module Feature.Auth.JwtCacheSpec where
+
+import qualified Data.Map as M
+
+import Network.HTTP.Types
+import Network.Wai.Test    (SResponse (simpleHeaders, simpleStatus))
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+import PostgREST.Config (AppConfig (..))
+
+import Protolude  hiding (get)
+import SpecHelper
+
+spec :: SpecWithConfig
+spec withConfig = do
+
+  withConfig baseCfg { configJwtCacheMaxEntries = 86400 } $ do
+    it "server-timing duration is exposed for JWT with expiry" $ do
+      !currentTime <- liftIO $ relativeSeconds 1800 -- 30 minutes, evaluate strictly
+      let jwtPayload = [json|{ "role": "postgrest_test_author", "exp": #{currentTime} }|]
+          auth = authHeaderJWT $ generateJWT jwtPayload
+
+      res1 <- request methodGet "/authors_only" [auth] ""
+      let jwtDur1 = M.lookup "jwt" $ parseServerTimingHeader $ simpleHeaders res1
+      res2 <- request methodGet "/authors_only" [auth] ""
+      let jwtDur2 = M.lookup "jwt" $ parseServerTimingHeader $ simpleHeaders res2
+
+      -- With jwt caching the parse time of second request with the same token
+      -- should be at least as fast as the first one
+      let dur2IsLessThanEq = fromMaybe False $ liftA2 (<=) jwtDur2 jwtDur1
+      liftIO $ dur2IsLessThanEq `shouldBe` True
+
+    it "server-timing duration is exposed for JWT without expiry" $ do
+      let jwtPayload = [json|{ "role": "postgrest_test_author" }|]
+          auth = authHeaderJWT $ generateJWT jwtPayload
+
+      res1 <- request methodGet "/authors_only" [auth] ""
+      let jwtDur1 = M.lookup "jwt" $ parseServerTimingHeader $ simpleHeaders res1
+      res2 <- request methodGet "/authors_only" [auth] ""
+      let jwtDur2 = M.lookup "jwt" $ parseServerTimingHeader $ simpleHeaders res2
+
+      liftIO $ do
+        simpleStatus res1 `shouldBe` status200
+        simpleStatus res2 `shouldBe` status200
+
+      let dur1Positive = maybe False (>= 0) jwtDur1
+      let dur2Positive = maybe False (>= 0) jwtDur2
+      liftIO $ do
+        dur1Positive `shouldBe` True
+        dur2Positive `shouldBe` True
+
+  withConfig baseCfg { configServerTimingEnabled = False, configJwtCacheMaxEntries = 86400 } $
+    it "JWT cache does not break requests with server-timing disabled" $ do
+      let jwtPayload = [json|{ "role": "postgrest_test_author" }|]
+          auth = authHeaderJWT $ generateJWT jwtPayload
+
+      request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200
+      request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200

test/spec/Main.hs

@@ -24,6 +24,7 @@ import qualified Feature.Auth.AsymmetricJwtSpec
 import qualified Feature.Auth.AudienceJwtSecretSpec
 import qualified Feature.Auth.AuthSpec
 import qualified Feature.Auth.BinaryJwtSecretSpec
+import qualified Feature.Auth.JwtCacheSpec
 import qualified Feature.Auth.NoAnonSpec
 import qualified Feature.Auth.NoJwtSecretSpec
 import qualified Feature.ConcurrentSpec
@@ -115,6 +116,7 @@ main = do
         , ("Feature.Auth.AudienceJwtSecretSpec"                , Feature.Auth.AudienceJwtSecretSpec.spec)
         , ("Feature.Auth.AuthSpec"                             , Feature.Auth.AuthSpec.spec)
         , ("Feature.Auth.BinaryJwtSecretSpec"                  , Feature.Auth.BinaryJwtSecretSpec.spec)
+        , ("Feature.Auth.JwtCacheSpec"                         , Feature.Auth.JwtCacheSpec.spec)
         , ("Feature.Auth.NoAnonSpec"                           , Feature.Auth.NoAnonSpec.spec)
         , ("Feature.Auth.NoJwtSecretSpec"                      , Feature.Auth.NoJwtSecretSpec.spec)
         , ("Feature.ConcurrentSpec"                            , Feature.ConcurrentSpec.spec)

test/spec/SpecHelper.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module SpecHelper where
 
 import           Control.Lens           ((^?))
@@ -83,6 +84,26 @@ matchServerTimingHasTiming metric = MatchHeader $ \headers _body ->
                   else Just $ "missing metric: " <> metric <> "\n"
     Nothing  -> Just "missing Server-Timing header\n"
 
+parseServerTimingHeader :: [Header] -> M.Map BS.ByteString Double
+parseServerTimingHeader []     = M.empty
+parseServerTimingHeader (h:hs) =
+  case h of
+    ("Server-Timing", timingHeader) ->
+      let
+        timings = BS.split ',' timingHeader
+      in
+        M.fromList $ mapMaybe splitEachTiming timings
+    _ -> parseServerTimingHeader hs
+  where
+    splitEachTiming :: ByteString -> Maybe (BS.ByteString, Double)
+    splitEachTiming t =
+      case BS.split ';' t of
+        [name, durationText] ->
+          case BS.split '=' durationText of
+            [_, duration] -> (name,) <$> readMaybe (BS.unpack duration)
+            _ -> Nothing
+        _ -> Nothing
+
 validateOpenApiResponse :: [Header] -> WaiSession () ()
 validateOpenApiResponse headers = do
   r <- request methodGet "/" headers ""