diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,17 @@ 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. +- Support GHC up to and including 9.12 1.2.0 ======= diff --git a/lib/Prometheus/Servant/Internal.hs b/lib/Prometheus/Servant/Internal.hs --- a/lib/Prometheus/Servant/Internal.hs +++ b/lib/Prometheus/Servant/Internal.hs @@ -225,11 +225,30 @@ 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 +#if MIN_VERSION_servant(0,20,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 diff --git a/servant-prometheus.cabal b/servant-prometheus.cabal --- a/servant-prometheus.cabal +++ b/servant-prometheus.cabal @@ -5,7 +5,7 @@ -- 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 @@ -18,8 +18,11 @@ build-type: Simple tested-with: GHC == 9.2.8 - , GHC == 9.4.7 , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.2 + , GHC == 9.10.1 + , GHC == 9.12.1 extra-source-files: README.md LICENSE @@ -49,14 +52,14 @@ UndecidableInstances ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-inferred-safe-imports -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-implicit-prelude build-depends: - base >=4.10 && <4.18 + base >=4.10 && <4.22 , 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.14 + , 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 default-language: GHC2021 @@ -81,20 +84,21 @@ build-tool-depends: hspec-discover:hspec-discover build-depends: - aeson >=2.0 && <2.2 - , base >=4.10 && <4.18 - , containers >=0.6.5 && <0.7 + aeson >=2.0 && <2.3 + , base >=4.10 && <4.22 + , containers >=0.6.5 && <0.9 , 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.20 + , servant-client >=0.14 && <0.21 , servant-prometheus - , servant-server >=0.14 && <0.20 + , servant-server >=0.14 && <0.21 , text , wai - , warp >=3.2.4 && <3.4 + , warp >=3.2.4 && <3.5 default-language: GHC2021 benchmark bench @@ -115,7 +119,7 @@ UndecidableInstances ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-inferred-safe-imports -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-implicit-prelude -threaded "-with-rtsopts=-N -A64m -AL256m" build-depends: - base >=4.10 && <4.18 + base >=4.10 && <4.22 , process >=1.6.16 && <1.7 , servant-prometheus , servant-server diff --git a/test/Prometheus/ServantSpec.hs b/test/Prometheus/ServantSpec.hs --- a/test/Prometheus/ServantSpec.hs +++ b/test/Prometheus/ServantSpec.hs @@ -6,11 +6,15 @@ 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 +22,14 @@ , Post , Proxy (..) , QueryParam + , Raw , ReqBody , Server , serve , (:<|>) (..) , (:>) ) +import Servant qualified import Servant.Client ( BaseUrl (..) , ClientError @@ -44,7 +50,7 @@ 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 +60,7 @@ _ <- 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 +68,10 @@ `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 +82,7 @@ `shouldBe` [ Endpoint ["hello", ":name"] "GET" , Endpoint ["greet"] "POST" , Endpoint ["greet", ":greetid"] "DELETE" + , Endpoint ["proxy", "*"] "RAW" ] -- * Example @@ -94,6 +103,8 @@ :<|> "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 :> Raw testApi :: Proxy TestApi testApi = Proxy @@ -105,7 +116,7 @@ -- -- 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 @@ -114,6 +125,9 @@ postGreetH = pure deleteGreetH _ = pure NoContent + + 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.