diff --git a/test/spec/Feature/Auth/JwtCacheSpec.hs b/test/spec/Feature/Auth/JwtCacheSpec.hs index 164a6f032..7aff856fd 100644 --- a/test/spec/Feature/Auth/JwtCacheSpec.hs +++ b/test/spec/Feature/Auth/JwtCacheSpec.hs @@ -13,17 +13,13 @@ where import Network.Wai (Application) import Network.HTTP.Types -import Test.Hspec (Expectation, SpecWith, describe, it, - shouldBe) +import Test.Hspec (SpecWith, describe, it) import Test.Hspec.Wai -import Data.String (String) -import PostgREST.Metrics (MetricsState (..)) -import Prometheus (getCounter) +import PostgREST.Metrics (MetricsState (..)) import Protolude import SpecHelper -import Test.Hspec.Expectations.Contrib (annotate) -import Test.Hspec.Wai.JSON (json) +import Test.Hspec.Wai.JSON (json) spec :: SpecWith (MetricsState, Application) spec = describe "Server started with JWT and metrics enabled" $ do @@ -143,25 +139,8 @@ spec = describe "Server started with JWT and metrics enabled" $ do *> request methodGet "/authors_only" [jwt3] "" where - counterToInt = second (fmap (round @Double @Int) . getCounter) - expectCounters = stateCheck . fmap (\(g, h) -> StateCheck (counterToInt . g) (flip shouldBe . h)) genToken = authHeaderJWT . generateJWT - requests = (,) (getF @"jwtCacheRequests") - hits = (,) (getF @"jwtCacheHits") - evictions = (,) (getF @"jwtCacheEvictions") - - --- should be moved to helpers??? -getF :: forall s r a. (KnownSymbol s, HasField s r a) => r -> (String, a) -getF r = (symbolVal (Proxy @s), getField @s r) - -data StateCheck st = forall a. (Show a, Eq a) => StateCheck (st -> (String, WaiSession st a)) (a -> a -> Expectation) - -stateCheck :: (Traversable t) => t (StateCheck st) -> WaiSession st a -> WaiSession st () -stateCheck checks act = do - metrics <- getState - expectations <- traverse (\(StateCheck g expect) -> let (msg, m) = g metrics in m >>= createExpectation msg m . expect) checks - void act - sequenceA_ expectations - where - createExpectation msg metrics expect = pure $ metrics >>= liftIO . annotate msg . expect + requests = expectCounter @"jwtCacheRequests" + hits = expectCounter @"jwtCacheHits" + evictions = expectCounter @"jwtCacheEvictions" + expectCounters = checkState diff --git a/test/spec/SpecHelper.hs b/test/spec/SpecHelper.hs index 3c48a1134..a35d7db92 100644 --- a/test/spec/SpecHelper.hs +++ b/test/spec/SpecHelper.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module SpecHelper where import Control.Lens ((^?)) @@ -36,8 +42,10 @@ import PostgREST.Config (AppConfig (..), OpenAPIMode (..), parseSecret) import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..)) +import Prometheus (Counter, getCounter) import Protolude hiding (get, toS) import Protolude.Conv (toS) +import Test.Hspec.Expectations.Contrib (annotate) filterAndMatchCT :: BS.ByteString -> MatchHeader filterAndMatchCT val = MatchHeader $ \headers _ -> @@ -346,3 +354,29 @@ getInsertDataForTiobePlsTable rows = readFixtureFile :: FilePath -> BL.ByteString readFixtureFile file = unsafePerformIO $ BL.readFile $ "test/spec/fixtures/" <> file + +-- state check helpers + +data StateCheck st m = forall a. StateCheck (st -> (String, m a)) (a -> a -> Expectation) + +stateCheck :: (Show a, Eq a) => (c -> m a) -> (st -> (String, c)) -> (a -> a) -> StateCheck st m +stateCheck extractValue extractComponent expect = StateCheck (second extractValue . extractComponent) (flip shouldBe . expect) + +expectField :: forall s st a c m. (KnownSymbol s, Show a, Eq a, HasField s st c) => (c -> m a) -> (a -> a) -> StateCheck st m +expectField extractValue = stateCheck extractValue ((symbolVal (Proxy @s),) . getField @s) + +checkState :: (Traversable t) => t (StateCheck st (WaiSession st)) -> WaiSession st b -> WaiSession st () +checkState checks act = getState >>= flip (`checkState'` checks) act + +checkState' :: (Traversable t, MonadIO m) => st -> t (StateCheck st m) -> m b -> m () +checkState' initialState checks act = do + expectations <- traverse (\(StateCheck g expect) -> let (msg, m) = g initialState in m >>= createExpectation msg m . expect) checks + void act + sequenceA_ expectations + where + createExpectation msg metrics expect = pure $ metrics >>= liftIO . annotate msg . expect + +expectCounter :: forall s st m. (KnownSymbol s, HasField s st Counter, MonadIO m) => (Int -> Int) -> StateCheck st m +expectCounter = expectField @s intCounter + where + intCounter = ((round @Double @Int) <$>) . getCounter