Fix CaptureAll and support for RawM WithResource

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
 =======

lib/Prometheus/Servant/Internal.hs

@@ -225,11 +225,30 @@ instance HasEndpoint Raw where
   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

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 <https://github.com/worm2fed/servant-prometheus#readme>
@@ -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:

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 <https://github.com/worm2fed/servant-prometheus#readme>
 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

test/Prometheus/ServantSpec.hs

@@ -6,24 +6,30 @@ 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
   , NoContent (..)
   , Post
   , Proxy (..)
   , QueryParam
+  , Raw
   , ReqBody
   , Server
   , serve
   , (:<|>) (..)
   , (:>)
   )
+import Servant qualified
 import Servant.Client
   ( BaseUrl (..)
   , ClientError
@@ -44,7 +50,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,16 +60,18 @@ 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
       map fst latencies
         `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 @@ spec = describe "servant-prometheus" $ do
       `shouldBe` [ Endpoint ["hello", ":name"] "GET"
                  , Endpoint ["greet"] "POST"
                  , Endpoint ["greet", ":greetid"] "DELETE"
+                 , Endpoint ["proxy", "*"] "RAW"
                  ]
 
 -- * Example
@@ -94,6 +103,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 :> Raw
 
 testApi :: Proxy TestApi
 testApi = Proxy
@@ -105,7 +116,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 +126,9 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
 
     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.
 test :: Application