From 76e30ea8214c7e88cf1910ce990a5e080aeafea2 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 1/5] 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 From 5b9228808e21a646dfa9d73da86df610fd11e9f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Handr=C3=A9=20Stolp?= Date: Mon, 25 Nov 2024 11:54:48 +0000 Subject: [PATCH 2/5] update package.yaml to reflect cabal file --- package.yaml | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/package.yaml b/package.yaml index 5b824a6..adc7bbd 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: servant-prometheus -version: 1.2.0 +version: 1.3.0 github: worm2fed/servant-prometheus synopsis: Helpers for using prometheus with servant description: Please see the README on GitHub at @@ -71,18 +71,18 @@ ghc-options: - -Wno-implicit-prelude dependencies: - - base >=4.10 && < 4.18 + - base >=4.10 && < 4.21 library: source-dirs: lib dependencies: - clock >= 0.8.3 && < 0.9 - - ghc-prim >= 0.8.0 && < 0.10 - - hashable >= 1.4.2 && < 1.5 + - ghc-prim >= 0.8.0 && < 0.12 + - hashable >= 1.4.2 && < 1.6 - http-types >= 0.12.3 && < 0.13 - prometheus-client >= 1.1.0 && < 1.2 - - servant >= 0.14 && < 0.20 - - text >= 1.2.5 && < 2.1 + - servant >= 0.14 && < 0.21 + - text >= 1.2.5 && < 2.2 - wai >= 3.2.3 && < 3.3 tests: @@ -97,18 +97,19 @@ tests: dependencies: - servant-prometheus - - aeson >= 2.0 && < 2.2 - - containers >= 0.6.5 && < 0.7 + - aeson >= 2.0 && < 2.3 + - containers >= 0.6.5 && < 0.8 - hspec >= 2 && < 3 - 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.20 - - servant-server >= 0.14 && < 0.20 + - servant-client >= 0.14 && < 0.21 + - servant-server >= 0.14 && < 0.21 - text - wai - - warp >= 3.2.4 && < 3.4 + - warp >= 3.2.4 && < 3.5 benchmarks: bench: From d3be720c9f63f880033016d9a7e99a86ca0c263c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Handr=C3=A9=20Stolp?= Date: Mon, 25 Nov 2024 12:18:55 +0000 Subject: [PATCH 3/5] Switch tests to `Raw` from `RawM` since RawM is only in servant 0.20 --- test/Prometheus/ServantSpec.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/test/Prometheus/ServantSpec.hs b/test/Prometheus/ServantSpec.hs index ce29a8d..0e9d3ef 100644 --- a/test/Prometheus/ServantSpec.hs +++ b/test/Prometheus/ServantSpec.hs @@ -1,6 +1,5 @@ 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) @@ -23,7 +22,7 @@ import Servant , Post , Proxy (..) , QueryParam - , RawM + , Raw , ReqBody , Server , serve @@ -105,7 +104,7 @@ type TestApi = -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent -- GET /proxy/some/proxy/route - :<|> "proxy" :> CaptureAll "proxyRoute" Text :> RawM + :<|> "proxy" :> CaptureAll "proxyRoute" Text :> Raw testApi :: Proxy TestApi testApi = Proxy @@ -127,12 +126,8 @@ server = helloH :<|> postGreetH :<|> deleteGreetH :<|> proxyH 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" + proxyH :: [Text] -> Servant.Tagged Servant.Handler Wai.Application + proxyH _ = Servant.Tagged $ \_ responder -> responder $ Wai.responseLBS ok200 [] "success" -- | Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. From 7faa7c2f3e5d4a1e0058305a2804b1a79be22c76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Handr=C3=A9=20Stolp?= Date: Mon, 25 Nov 2024 13:03:17 +0000 Subject: [PATCH 4/5] Version gate RawM and WithResource instances --- lib/Prometheus/Servant/Internal.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/Prometheus/Servant/Internal.hs b/lib/Prometheus/Servant/Internal.hs index d9d2576..6997fd7 100644 --- a/lib/Prometheus/Servant/Internal.hs +++ b/lib/Prometheus/Servant/Internal.hs @@ -224,11 +224,6 @@ 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 @@ -246,7 +241,14 @@ instance HasEndpoint (sub :: Type) => HasEndpoint (BasicAuth (realm :: Symbol) a enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) +#if MIN_VERSION_servant(0,2,0) instance HasEndpoint (sub :: Type) => HasEndpoint (WithResource a :> sub) where getEndpoint _ = getEndpoint (Proxy :: Proxy sub) enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) + +instance HasEndpoint RawM where + getEndpoint _ _ = Just (Endpoint [] "RAW") + + enumerateEndpoints _ = [Endpoint [] "RAW"] +#endif From cdcdabeada7fda9cbc8c6c367d5b871aa3327748 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Handr=C3=A9=20Stolp?= Date: Mon, 25 Nov 2024 14:50:40 +0000 Subject: [PATCH 5/5] Fix servant min version bounds to be 0.20.0 not 0.2.0 --- lib/Prometheus/Servant/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Prometheus/Servant/Internal.hs b/lib/Prometheus/Servant/Internal.hs index 6997fd7..3d642ea 100644 --- a/lib/Prometheus/Servant/Internal.hs +++ b/lib/Prometheus/Servant/Internal.hs @@ -241,7 +241,7 @@ instance HasEndpoint (sub :: Type) => HasEndpoint (BasicAuth (realm :: Symbol) a enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) -#if MIN_VERSION_servant(0,2,0) +#if MIN_VERSION_servant(0,20,0) instance HasEndpoint (sub :: Type) => HasEndpoint (WithResource a :> sub) where getEndpoint _ = getEndpoint (Proxy :: Proxy sub)