From 681c9c53bbcf21ea17dd7081ec8a760c8aeec06d Mon Sep 17 00:00:00 2001
From: Akshay Mankar <akshay@wire.com>
Date: Tue, 9 Nov 2021 16:30:49 +0100
Subject: [PATCH] Report QualifiedCapture correctly in prometheus metrics

For prometheus metrics middleware to be able to replace
/users/4f7cbd8c-5fe3-4818-94c0-8ae68460ba13 with /users/:uid, it needs to know
the paths in servant that exist. This is generated statically using the class
`RoutesToPaths`. This class had an overlappable instance for everything, this
caused to not notice when we created the QualifiedCapture type. In order to
ensure that we instantiate this class correctly, this commit removes this
catch-all instance and instantiate the class for every type that needs it
explicitly.
---
 changelog.d/3-bug-fixes/metrics-handlers      |  1 +
 libs/extended/extended.cabal                  |  3 +-
 libs/extended/package.yaml                    |  1 +
 libs/extended/src/Servant/API/Extended.hs     |  4 ++
 libs/metrics-wai/metrics-wai.cabal            |  4 +-
 libs/metrics-wai/package.yaml                 |  1 +
 libs/metrics-wai/src/Data/Metrics/Servant.hs  | 61 +++++++++++++------
 libs/wire-api/package.yaml                    | 13 ++--
 .../wire-api/src/Wire/API/ErrorDescription.hs |  4 ++
 .../wire-api/src/Wire/API/Routes/MultiVerb.hs |  4 ++
 libs/wire-api/src/Wire/API/Routes/Public.hs   |  7 +++
 .../src/Wire/API/Routes/QualifiedCapture.hs   |  9 +++
 libs/wire-api/test/unit/Main.hs               |  4 +-
 .../test/unit/Test/Wire/API/Routes.hs         | 23 +++++++
 libs/wire-api/wire-api.cabal                  |  6 +-
 15 files changed, 117 insertions(+), 28 deletions(-)
 create mode 100644 changelog.d/3-bug-fixes/metrics-handlers
 create mode 100644 libs/wire-api/test/unit/Test/Wire/API/Routes.hs

diff --git a/changelog.d/3-bug-fixes/metrics-handlers b/changelog.d/3-bug-fixes/metrics-handlers
new file mode 100644
index 0000000000..9104e64006
--- /dev/null
+++ b/changelog.d/3-bug-fixes/metrics-handlers
@@ -0,0 +1 @@
+Ensure that all endpoints have a correct handler in prometheus metrics
\ No newline at end of file
diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal
index ccadad0f1b..4c7304bccc 100644
--- a/libs/extended/extended.cabal
+++ b/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
diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml
index a2239b49a1..aa4cdd43ab 100644
--- a/libs/extended/package.yaml
+++ b/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
diff --git a/libs/extended/src/Servant/API/Extended.hs b/libs/extended/src/Servant/API/Extended.hs
index 4b69d1561f..90e1a8516f 100644
--- a/libs/extended/src/Servant/API/Extended.hs
+++ b/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
diff --git a/libs/metrics-wai/metrics-wai.cabal b/libs/metrics-wai/metrics-wai.cabal
index 3631c86077..7658bf9348 100644
--- a/libs/metrics-wai/metrics-wai.cabal
+++ b/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
diff --git a/libs/metrics-wai/package.yaml b/libs/metrics-wai/package.yaml
index 85b90bb530..75e681fd7a 100644
--- a/libs/metrics-wai/package.yaml
+++ b/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
diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs
index b1398b9cb4..1bcac5d86e 100644
--- a/libs/metrics-wai/src/Data/Metrics/Servant.hs
+++ b/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,27 +80,59 @@ 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
   ) =>
@@ -107,13 +140,5 @@ instance
   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 = []
diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml
index 9d813db174..adb7ee7146 100644
--- a/libs/wire-api/package.yaml
+++ b/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
diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs
index 11f2824072..7626722faf 100644
--- a/libs/wire-api/src/Wire/API/ErrorDescription.hs
+++ b/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) =>
diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs
index be89caee6c..79b9f50825 100644
--- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs
+++ b/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 = []
diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs
index 9dcf906651..f52a0cc0fe 100644
--- a/libs/wire-api/src/Wire/API/Routes/Public.hs
+++ b/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
diff --git a/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs b/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs
index 9e4f2ab24c..78febbd579 100644
--- a/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs
+++ b/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
+       )
diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs
index 982dff2fca..2ac40db0d9 100644
--- a/libs/wire-api/test/unit/Main.hs
+++ b/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
       ]
diff --git a/libs/wire-api/test/unit/Test/Wire/API/Routes.hs b/libs/wire-api/test/unit/Test/Wire/API/Routes.hs
new file mode 100644
index 0000000000..0c28074f69
--- /dev/null
+++ b/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)
diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal
index 623fa0c173..42843d6f7c 100644
--- a/libs/wire-api/wire-api.cabal
+++ b/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