Report QualifiedCapture correctly in prometheus metrics

changelog.d/3-bug-fixes/metrics-handlers

@@ -0,0 +1 @@
+Ensure that all endpoints have a correct handler in prometheus metrics

libs/extended/extended.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 18004f2559de4d4ac804d0a36a2d2780d0bbc10d79ebf78f337c9e6ba7a4ff3f
+-- hash: 65015665656bc1ae721971ef3e88ed707aa7a2be02ba04cf4aab39ac6188714a
 
 name:           extended
 version:        0.1.0
@@ -42,6 +42,7 @@ library
     , extra
     , http-types
     , imports
+    , metrics-wai
     , optparse-applicative
     , servant
     , servant-server

libs/extended/package.yaml

@@ -27,6 +27,7 @@ dependencies:
 # for servant's 'ReqBodyCustomError' type defined here.
 - errors
 - http-types
+- metrics-wai
 - servant
 - servant-server
 - servant-swagger

libs/extended/src/Servant/API/Extended.hs

@@ -23,6 +23,7 @@ module Servant.API.Extended where
 
 import qualified Data.ByteString.Lazy as BL
 import Data.EitherR (fmapL)
+import Data.Metrics.Servant
 import Data.String.Conversions (cs)
 import Data.Typeable
 import GHC.TypeLits
@@ -113,3 +114,6 @@ instance
   HasSwagger (ReqBodyCustomError cts tag a :> api)
   where
   toSwagger Proxy = toSwagger (Proxy @(ReqBody' '[Required, Strict] cts a :> api))
+
+instance RoutesToPaths rest => RoutesToPaths (ReqBodyCustomError' mods list tag a :> rest) where
+  getRoutes = getRoutes @rest

libs/metrics-wai/metrics-wai.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1fdffa4b08c579feb0c18fe4c3c12c81ee6c503b5672735f7df5a02e02081c67
+-- hash: aefa1a394ca2caa5cad577e67967aace67b79d4c94afeba4dd399b77de826a6c
 
 name:           metrics-wai
 version:        0.5.7
@@ -40,6 +40,7 @@ library
     , imports
     , metrics-core >=0.3
     , servant
+    , servant-multipart
     , string-conversions
     , text >=0.11
     , wai >=3
@@ -70,6 +71,7 @@ test-suite unit
     , metrics-core >=0.3
     , metrics-wai
     , servant
+    , servant-multipart
     , string-conversions
     , text >=0.11
     , wai >=3

libs/metrics-wai/package.yaml

@@ -16,6 +16,7 @@ dependencies:
 - metrics-core >=0.3
 - containers
 - servant
+- servant-multipart
 - string-conversions
 - text >=0.11
 - wai >=3

libs/metrics-wai/src/Data/Metrics/Servant.hs

@@ -40,6 +40,7 @@ import Network.Wai.Middleware.Prometheus
 import qualified Network.Wai.Middleware.Prometheus as Promth
 import Network.Wai.Routing (Routes, prepare)
 import Servant.API
+import Servant.Multipart
 
 -- | This does not catch errors, so it must be called outside of 'WU.catchErrors'.
 servantPrometheusMiddleware :: forall proxy api. (RoutesToPaths api) => proxy api -> Wai.Middleware
@@ -79,41 +80,65 @@ class RoutesToPaths routes where
 
 -- "seg" :> routes
 instance
-  {-# OVERLAPPING #-}
-  ( KnownSymbol seg,
-    RoutesToPaths segs
-  ) =>
+  (KnownSymbol seg, RoutesToPaths segs) =>
   RoutesToPaths (seg :> segs)
   where
   getRoutes = [Node (Right . cs $ symbolVal (Proxy @seg)) (getRoutes @segs)]
 
 -- <capture> :> routes
 instance
-  {-# OVERLAPPING #-}
-  ( KnownSymbol capture,
-    RoutesToPaths segs
-  ) =>
+  (KnownSymbol capture, RoutesToPaths segs) =>
   RoutesToPaths (Capture' mods capture a :> segs)
   where
   getRoutes = [Node (Left (cs (":" <> symbolVal (Proxy @capture)))) (getRoutes @segs)]
 
+instance
+  (RoutesToPaths rest) =>
+  RoutesToPaths (Header' mods name a :> rest)
+  where
+  getRoutes = getRoutes @rest
+
+instance
+  (RoutesToPaths rest) =>
+  RoutesToPaths (ReqBody' mods cts a :> rest)
+  where
+  getRoutes = getRoutes @rest
+
+instance
+  (RoutesToPaths rest) =>
+  RoutesToPaths (Summary summary :> rest)
+  where
+  getRoutes = getRoutes @rest
+
+instance
+  RoutesToPaths rest =>
+  RoutesToPaths (QueryParam' mods name a :> rest)
+  where
+  getRoutes = getRoutes @rest
+
+instance RoutesToPaths rest => RoutesToPaths (MultipartForm tag a :> rest) where
+  getRoutes = getRoutes @rest
+
+instance
+  RoutesToPaths rest =>
+  RoutesToPaths (Description desc :> rest)
+  where
+  getRoutes = getRoutes @rest
+
+instance RoutesToPaths (Verb method status cts a) where
+  getRoutes = []
+
+instance RoutesToPaths (NoContentVerb method) where
+  getRoutes = []
+
 -- route :<|> routes
 instance
-  {-# OVERLAPPING #-}
   ( RoutesToPaths route,
     RoutesToPaths routes
   ) =>
   RoutesToPaths (route :<|> routes)
   where
   getRoutes = getRoutes @route <> getRoutes @routes
 
-instance
-  {-# OVERLAPPABLE #-}
-  ( RoutesToPaths segs
-  ) =>
-  RoutesToPaths (anything :> segs)
-  where
-  getRoutes = getRoutes @segs
-
-instance {-# OVERLAPPABLE #-} RoutesToPaths anything where
+instance RoutesToPaths Raw where
   getRoutes = []

libs/wire-api/package.yaml

@@ -10,14 +10,16 @@ copyright: (c) 2020 Wire Swiss GmbH
 license: AGPL-3
 dependencies:
 - aeson >=0.6
-- containers >=0.5
-- imports
-- types-common >=0.16
-- servant-swagger-ui
 - case-insensitive
+- containers >=0.5
+- filepath
 - hscim
+- imports
+- metrics-wai
 - saml2-web-sso
-- filepath
+- servant
+- servant-swagger-ui
+- types-common >=0.16
 library:
   source-dirs: src
   dependencies:
@@ -62,7 +64,6 @@ library:
   - QuickCheck >=2.14
   - quickcheck-instances >=0.3.16
   - resourcet
-  - servant
   - servant-client
   - servant-client-core
   - servant-multipart

libs/wire-api/src/Wire/API/ErrorDescription.hs

@@ -3,6 +3,7 @@ module Wire.API.ErrorDescription where
 import Control.Lens (at, (%~), (.~), (<>~), (?~))
 import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy as LBS
+import Data.Metrics.Servant
 import Data.SOP (I (..), NP (..), NS (..))
 import Data.Schema
 import Data.Swagger (Swagger)
@@ -45,6 +46,9 @@ instance
   route _ = route (Proxy @api)
   hoistServerWithContext _ = hoistServerWithContext (Proxy @api)
 
+instance RoutesToPaths api => RoutesToPaths (CanThrow err :> api) where
+  getRoutes = getRoutes @api
+
 errorDescriptionAddToSwagger ::
   forall (code :: Nat) (label :: Symbol) (desc :: Symbol).
   (KnownStatus code, KnownSymbol label, KnownSymbol desc) =>

libs/wire-api/src/Wire/API/Routes/MultiVerb.hs

@@ -47,6 +47,7 @@ import qualified Data.ByteString.Lazy as LBS
 import Data.Containers.ListUtils
 import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
+import Data.Metrics.Servant
 import Data.Proxy
 import Data.SOP
 import qualified Data.Sequence as Seq
@@ -633,3 +634,6 @@ instance
       method = reflectMethod (Proxy @method)
 
   hoistClientMonad _ _ f = f
+
+instance RoutesToPaths (MultiVerb method cs as r) where
+  getRoutes = []

libs/wire-api/src/Wire/API/Routes/Public.hs

@@ -23,6 +23,7 @@ module Wire.API.Routes.Public where
 import Control.Lens ((<>~))
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Id as Id
+import Data.Metrics.Servant
 import Data.Swagger
 import GHC.Base (Symbol)
 import GHC.TypeLits (KnownSymbol)
@@ -94,6 +95,9 @@ instance
   hoistServerWithContext _ pc nt s =
     Servant.hoistServerWithContext (Proxy @(InternalAuth ztype opts :> api)) pc nt s
 
+instance RoutesToPaths api => RoutesToPaths (ZAuthServant ztype opts :> api) where
+  getRoutes = getRoutes @api
+
 -- FUTUREWORK: Make a PR to the servant-swagger package with this instance
 instance ToSchema a => ToSchema (Headers ls a) where
   declareNamedSchema _ = declareNamedSchema (Proxy @a)
@@ -116,3 +120,6 @@ instance HasServer api ctx => HasServer (OmitDocs :> api) ctx where
   route _ = route (Proxy :: Proxy api)
   hoistServerWithContext _ pc nt s =
     hoistServerWithContext (Proxy :: Proxy api) pc nt s
+
+instance RoutesToPaths api => RoutesToPaths (OmitDocs :> api) where
+  getRoutes = getRoutes @api

libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs

@@ -22,6 +22,7 @@ module Wire.API.Routes.QualifiedCapture
 where
 
 import Data.Domain
+import Data.Metrics.Servant
 import Data.Qualified
 import Data.Swagger
 import GHC.TypeLits
@@ -96,3 +97,11 @@ instance
   clientWithRoute pm _ req (Qualified value domain) =
     clientWithRoute pm (Proxy @(WithDomain mods capture a api)) req domain value
   hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @api) f . cl
+
+instance (RoutesToPaths api, KnownSymbol (AppendSymbol capture "_domain"), KnownSymbol capture) => RoutesToPaths (QualifiedCapture' mods capture a :> api) where
+  getRoutes =
+    getRoutes
+      @( Capture' mods (AppendSymbol capture "_domain") Domain
+           :> Capture' mods capture a
+           :> api
+       )

libs/wire-api/test/unit/Main.hs

@@ -30,6 +30,7 @@ import qualified Test.Wire.API.Golden.Protobuf as Golden.Protobuf
 import qualified Test.Wire.API.Roundtrip.Aeson as Roundtrip.Aeson
 import qualified Test.Wire.API.Roundtrip.ByteString as Roundtrip.ByteString
 import qualified Test.Wire.API.Roundtrip.CSV as Roundtrip.CSV
+import qualified Test.Wire.API.Routes as Routes
 import qualified Test.Wire.API.Swagger as Swagger
 import qualified Test.Wire.API.Team.Member as Team.Member
 import qualified Test.Wire.API.User as User
@@ -53,5 +54,6 @@ main =
         Golden.Generated.tests,
         Golden.Manual.tests,
         Golden.FromJSON.tests,
-        Golden.Protobuf.tests
+        Golden.Protobuf.tests,
+        Routes.tests
       ]

libs/wire-api/test/unit/Test/Wire/API/Routes.hs

@@ -0,0 +1,23 @@
+module Test.Wire.API.Routes where
+
+import Data.Metrics.Servant
+import Data.Tree
+import Imports
+import Servant.API
+import qualified Test.Tasty as T
+import Test.Tasty.HUnit
+import Wire.API.Routes.QualifiedCapture
+
+tests :: T.TestTree
+tests =
+  T.testGroup "Routes" $
+    [T.testGroup "QualifiedCapture" [testCase "must expose the captures in metrics" qualifiedCaptureMetrics]]
+
+type QualifiedCaptureAPI = "users" :> QualifiedCapture' '[] "uid" Int :> Get '[] Int
+
+qualifiedCaptureMetrics :: Assertion
+qualifiedCaptureMetrics =
+  assertEqual
+    "match metrics path"
+    [Node (Right "users") [Node (Left ":uid_domain") [Node (Left ":uid") []]]]
+    (getRoutes @QualifiedCaptureAPI)

libs/wire-api/wire-api.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 2d17ec32d1990b4f59c918291cd7a1286d20e5c54ad921ecd5eb9d01b4b9f1c8
+-- hash: 2e805d6416bf9f547993a1c6fb55d615479783065d19d63e639ffc443301ecee
 
 name:           wire-api
 version:        0.1.0
@@ -142,6 +142,7 @@ library
     , iso639 >=0.1
     , lens >=4.12
     , memory
+    , metrics-wai
     , mime >=0.4
     , mtl
     , pem >=0.2
@@ -424,6 +425,7 @@ test-suite wire-api-tests
       Test.Wire.API.Roundtrip.Aeson
       Test.Wire.API.Roundtrip.ByteString
       Test.Wire.API.Roundtrip.CSV
+      Test.Wire.API.Routes
       Test.Wire.API.Swagger
       Test.Wire.API.Team.Member
       Test.Wire.API.User
@@ -453,11 +455,13 @@ test-suite wire-api-tests
     , iso3166-country-codes
     , iso639
     , lens
+    , metrics-wai
     , mime
     , pem
     , pretty
     , proto-lens
     , saml2-web-sso
+    , servant
     , servant-swagger-ui
     , string-conversions
     , swagger2