Fix CaptureAll and support for RawM WithResource (#11)

* 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 `Raw` behave as expected.

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