From d7f3ff85777636d7b1960c3d1f48f08bcb37bbe2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Handr=C3=A9=20Stolp?= Date: Mon, 25 Nov 2024 10:20:06 +0000 Subject: [PATCH] Fix CaptureAll and support for RawM WithResource We fix the implementation of the CaptureAll instance. Previously paths would never be matched since the instance did not consume the rest of the path like `CaptureAll` does. The rest of the path is now captured and replaced with a `*` place holder and this is also the case for enumerating the endpoint. We also add instances for `RawM` and `WithResource` and add a test case to the spec to check that `CaptureAll` and `RawM` behave as expected. --- CHANGELOG.md | 10 ++++++++++ lib/Prometheus/Servant/Internal.hs | 19 ++++++++++++++++++- servant-prometheus.cabal | 3 ++- test/Prometheus/ServantSpec.hs | 25 ++++++++++++++++++++++--- 4 files changed, 52 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6259498..678cf9f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ Unreleased ========== +1.3.0 +======= + +- Add an `HasEndpoint` instance for `RawM` +- Add an `HasEndpoint` instance for `WithResource` +- Fix `HasEndpoint` instance for `CaptureAll` + - Previously paths would never be matched since the instance + did not consume the rest of the path like `CaptureAll` does. + The rest of the path is now captured and replaced with a `*` + place holder and this is also the case for enumerating the endpoint. 1.2.0 ======= diff --git a/lib/Prometheus/Servant/Internal.hs b/lib/Prometheus/Servant/Internal.hs index 7cbf7f9..d9d2576 100644 --- a/lib/Prometheus/Servant/Internal.hs +++ b/lib/Prometheus/Servant/Internal.hs @@ -224,12 +224,29 @@ instance HasEndpoint Raw where enumerateEndpoints _ = [Endpoint [] "RAW"] +instance HasEndpoint RawM where + getEndpoint _ _ = Just (Endpoint [] "RAW") + + enumerateEndpoints _ = [Endpoint [] "RAW"] + instance HasEndpoint (sub :: Type) => HasEndpoint (CaptureAll (h :: Symbol) a :> sub) where + getEndpoint _ req = + case pathInfo req of + [] -> Nothing + _ -> do + Endpoint{..} <- getEndpoint (Proxy :: Proxy sub) req{pathInfo = []} + pure $ Endpoint ("*" : ePathSegments) eMethod + + enumerateEndpoints _ = do + let qualify Endpoint{..} = Endpoint ("*" : ePathSegments) eMethod + map qualify $ enumerateEndpoints (Proxy :: Proxy sub) + +instance HasEndpoint (sub :: Type) => HasEndpoint (BasicAuth (realm :: Symbol) a :> sub) where getEndpoint _ = getEndpoint (Proxy :: Proxy sub) enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) -instance HasEndpoint (sub :: Type) => HasEndpoint (BasicAuth (realm :: Symbol) a :> sub) where +instance HasEndpoint (sub :: Type) => HasEndpoint (WithResource a :> sub) where getEndpoint _ = getEndpoint (Proxy :: Proxy sub) enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) diff --git a/servant-prometheus.cabal b/servant-prometheus.cabal index e1cf05f..12afefe 100644 --- a/servant-prometheus.cabal +++ b/servant-prometheus.cabal @@ -5,7 +5,7 @@ cabal-version: 2.4 -- see: https://github.com/sol/hpack name: servant-prometheus -version: 1.2.0 +version: 1.3.0 synopsis: Helpers for using prometheus with servant description: Please see the README on GitHub at category: Servant, Web, System @@ -87,6 +87,7 @@ test-suite spec , hspec ==2.* , hspec-expectations-pretty-diff >=0.7.2.2 && <0.8 , http-client >=0.7.13 && <0.8 + , http-types >=0.12.4 && <0.13 , prometheus-client , servant , servant-client >=0.14 && <0.21 diff --git a/test/Prometheus/ServantSpec.hs b/test/Prometheus/ServantSpec.hs index ed67e6f..ce29a8d 100644 --- a/test/Prometheus/ServantSpec.hs +++ b/test/Prometheus/ServantSpec.hs @@ -1,16 +1,21 @@ module Prometheus.ServantSpec (spec) where +import Control.Monad.IO.Class (liftIO) import Data.Aeson (FromJSON, ToJSON) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Types.Method (methodGet) +import Network.HTTP.Types.Status (ok200) import Network.Wai (Application) +import Network.Wai qualified as Wai import Network.Wai.Handler.Warp (Port, withApplication) import Prometheus qualified as P import Servant ( Capture + , CaptureAll , Delete , Get , JSON @@ -18,12 +23,14 @@ import Servant , Post , Proxy (..) , QueryParam + , RawM , ReqBody , Server , serve , (:<|>) (..) , (:>) ) +import Servant qualified import Servant.Client ( BaseUrl (..) , ClientError @@ -44,7 +51,7 @@ import Prometheus.Servant.Internal (Endpoint (..), HasEndpoint (..)) spec :: Spec spec = describe "servant-prometheus" $ do - let getEp :<|> postEp :<|> deleteEp = client testApi + let getEp :<|> postEp :<|> deleteEp :<|> proxyEp = client testApi it "collects number of request" $ withApp $ \port -> do @@ -54,6 +61,7 @@ spec = describe "servant-prometheus" $ do _ <- runFn $ getEp "name" Nothing _ <- runFn $ postEp (Greet "hi") _ <- runFn $ deleteEp "blah" + _ <- runFn $ proxyEp ["some", "proxy", "route"] methodGet let Metrics{..} = defaultMetrics latencies <- P.getVectorWith mLatency P.getHistogram @@ -61,9 +69,10 @@ spec = describe "servant-prometheus" $ do `shouldBe` [ ("/greet", "POST", "200") , ("/greet/:greetid", "DELETE", "200") , ("/hello/:name", "GET", "200") + , ("/proxy/*", "RAW", "200") ] map (sum . map snd . Map.toList . snd) latencies - `shouldBe` [1, 1, 1] + `shouldBe` [1, 1, 1, 1] it "is comprehensive" $ do let !_typeLevelTest = prometheusMiddleware defaultMetrics comprehensiveAPI @@ -74,6 +83,7 @@ spec = describe "servant-prometheus" $ do `shouldBe` [ Endpoint ["hello", ":name"] "GET" , Endpoint ["greet"] "POST" , Endpoint ["greet", ":greetid"] "DELETE" + , Endpoint ["proxy", "*"] "RAW" ] -- * Example @@ -94,6 +104,8 @@ type TestApi = :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + -- GET /proxy/some/proxy/route + :<|> "proxy" :> CaptureAll "proxyRoute" Text :> RawM testApi :: Proxy TestApi testApi = Proxy @@ -105,7 +117,7 @@ testApi = Proxy -- -- Each handler runs in the 'EitherT (Int, String) IO' monad. server :: Server TestApi -server = helloH :<|> postGreetH :<|> deleteGreetH +server = helloH :<|> postGreetH :<|> deleteGreetH :<|> proxyH where helloH name Nothing = helloH name (Just False) helloH name (Just False) = pure . Greet $ "Hello, " <> name @@ -115,6 +127,13 @@ server = helloH :<|> postGreetH :<|> deleteGreetH deleteGreetH _ = pure NoContent + proxyH + :: [Text] + -> Wai.Request + -> (Wai.Response -> IO Wai.ResponseReceived) + -> Servant.Handler Wai.ResponseReceived + proxyH _ req responder = liftIO $ responder $ Wai.responseLBS ok200 [] "success" + -- | Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. test :: Application