[WPB-1220] servantify proxy internal

changelog.d/5-internal/WPB-1220-servantify-proxy-internal

@@ -0,0 +1 @@
+Servantify internal routing table for proxy.

libs/metrics-wai/default.nix

@@ -14,6 +14,7 @@
 , servant
 , servant-multipart
 , text
+, types-common
 , utf8-string
 , wai
 , wai-middleware-prometheus
@@ -32,6 +33,7 @@ mkDerivation {
     servant
     servant-multipart
     text
+    types-common
     utf8-string
     wai
     wai-middleware-prometheus

libs/metrics-wai/metrics-wai.cabal

@@ -76,6 +76,7 @@ library
     , servant
     , servant-multipart
     , text                       >=0.11
+    , types-common
     , utf8-string
     , wai                        >=3
     , wai-middleware-prometheus

libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs

@@ -17,10 +17,12 @@
 
 module Data.Metrics.Middleware.Prometheus
   ( waiPrometheusMiddleware,
+    waiPrometheusMiddlewarePaths,
     normalizeWaiRequestRoute,
   )
 where
 
+import Data.Id
 import Data.Metrics.Types (Paths, treeLookup)
 import Data.Metrics.WaiRoute (treeToPaths)
 import Data.Text.Encoding qualified as T
@@ -33,12 +35,17 @@ import Network.Wai.Routing.Route (Routes, prepare)
 -- This middleware requires your servers 'Routes' because it does some normalization
 -- (e.g. removing params from calls)
 waiPrometheusMiddleware :: (Monad m) => Routes a m b -> Wai.Middleware
-waiPrometheusMiddleware routes =
+waiPrometheusMiddleware routes = waiPrometheusMiddlewarePaths $ treeToPaths $ prepare routes
+
+-- | Helper function that should only be needed as long as we have wai-routing code left in
+-- proxy: run 'treeToPaths' on old routing tables and 'routeToPaths' on the servant ones, and
+-- feed both to this function.
+waiPrometheusMiddlewarePaths :: Paths -> Wai.Middleware
+waiPrometheusMiddlewarePaths paths =
   Promth.prometheus conf . instrument (normalizeWaiRequestRoute paths)
   where
     -- See Note [Raw Response]
     instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses
-    paths = treeToPaths $ prepare routes
     conf =
       Promth.def
         { Promth.prometheusEndPoint = ["i", "metrics"],
@@ -57,4 +64,4 @@ normalizeWaiRequestRoute paths req = pathInfo
     -- Use the normalized path info if available; otherwise dump the raw path info for
     -- debugging purposes
     pathInfo :: Text
-    pathInfo = T.decodeUtf8 $ fromMaybe "N/A" mPathInfo
+    pathInfo = T.decodeUtf8 $ fromMaybe defRequestId mPathInfo

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

@@ -27,6 +27,7 @@
 module Data.Metrics.Servant where
 
 import Data.ByteString.UTF8 qualified as UTF8
+import Data.Id
 import Data.Metrics.Types
 import Data.Metrics.Types qualified as Metrics
 import Data.Proxy
@@ -49,7 +50,7 @@ servantPrometheusMiddleware _ = Promth.prometheus conf . instrument promthNormal
     promthNormalize req = pathInfo
       where
         mPathInfo = Metrics.treeLookup (routesToPaths @api) $ encodeUtf8 <$> Wai.pathInfo req
-        pathInfo = decodeUtf8With lenientDecode $ fromMaybe "N/A" mPathInfo
+        pathInfo = decodeUtf8With lenientDecode $ fromMaybe defRequestId mPathInfo
 
     -- See Note [Raw Response]
     instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses

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

@@ -41,6 +41,7 @@ newtype PathTemplate = PathTemplate Text
 -- (e.g. user id).
 newtype Paths = Paths (Forest PathSegment)
   deriving (Eq, Show)
+  deriving newtype (Semigroup)
 
 type PathSegment = Either ByteString ByteString
 

libs/types-common/src/Data/Id.hs

@@ -48,6 +48,7 @@ module Data.Id
     -- * Other IDs
     ConnId (..),
     RequestId (..),
+    defRequestId,
     BotId (..),
     NoId,
     OAuthClientId,
@@ -418,6 +419,9 @@ newtype RequestId = RequestId
       ToBytes
     )
 
+defRequestId :: (IsString s) => s
+defRequestId = "N/A"
+
 instance ToSchema RequestId where
   schema =
     RequestId . encodeUtf8

libs/wai-utilities/src/Network/Wai/Utilities/Request.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- This file is part of the Wire Server implementation.
@@ -56,7 +55,7 @@ lookupRequestId reqIdHeaderName =
 
 getRequestId :: HeaderName -> Request -> RequestId
 getRequestId reqIdHeaderName req =
-  RequestId $ fromMaybe "N/A" $ lookupRequestId reqIdHeaderName req
+  RequestId $ fromMaybe defRequestId $ lookupRequestId reqIdHeaderName req
 
 ----------------------------------------------------------------------------
 -- Typed JSON 'Request'

libs/wai-utilities/src/Network/Wai/Utilities/Server.hs

@@ -60,6 +60,7 @@ import Data.ByteString.Builder
 import Data.ByteString.Char8 qualified as C
 import Data.ByteString.Lazy qualified as LBS
 import Data.Domain (domainText)
+import Data.Id
 import Data.Metrics.GC (spawnGCMetricsCollector)
 import Data.Streaming.Zlib (ZlibException (..))
 import Data.Text.Encoding qualified as Text
@@ -168,7 +169,7 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes)
           r = reasonStr <$> reason e
           t = message e
        in case catMaybes [l, s, r] of
-            [] -> maybe "N/A" (LT.decodeUtf8With lenientDecode . LBS.fromStrict) t
+            [] -> maybe defRequestId (LT.decodeUtf8With lenientDecode . LBS.fromStrict) t
             bs -> LT.decodeUtf8With lenientDecode . toLazyByteString $ mconcat bs <> messageStr t
     labelStr [] = Nothing
     labelStr ls =
@@ -311,7 +312,7 @@ heavyDebugLogging sanitizeReq lvl lgr reqIdHeaderName app = \req cont -> do
     logMostlyEverything req bdy resp = Log.debug lgr logMsg
       where
         logMsg =
-          field "request" (fromMaybe "N/A" $ lookupRequestId reqIdHeaderName req)
+          field "request" (fromMaybe defRequestId $ lookupRequestId reqIdHeaderName req)
             . field "request_details" (show req)
             . field "request_body" bdy
             . field "response_status" (show $ responseStatus resp)
@@ -350,7 +351,7 @@ rethrow5xx getRequestId logger app req k = app req k'
       let logMsg =
             field "canoncalpath" (show $ pathInfo req)
               . field "rawpath" (rawPathInfo req)
-              . field "request" (fromMaybe "N/A" $ getRequestId req)
+              . field "request" (fromMaybe defRequestId $ getRequestId req)
               . msg (val "ResponseRaw - cannot collect metrics or log info on errors")
       Log.log logger Log.Debug logMsg
       k resp
@@ -436,7 +437,7 @@ logError' g mr e = liftIO $ doLog g (logErrorMsgWithRequest mr e)
 
 logJSONResponse :: (MonadIO m) => Logger -> Maybe ByteString -> JSONResponse -> m ()
 logJSONResponse g mReqId e = do
-  let r = fromMaybe "N/A" mReqId
+  let r = fromMaybe defRequestId mReqId
   liftIO $
     doLog g $
       field "request" r
@@ -462,7 +463,7 @@ logErrorMsg (Wai.Error c l m md inner) =
 
 logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg
 logErrorMsgWithRequest mr e =
-  field "request" (fromMaybe "N/A" mr) . logErrorMsg e
+  field "request" (fromMaybe defRequestId mr) . logErrorMsg e
 
 runHandlers :: SomeException -> [Handler IO a] -> IO a
 runHandlers e [] = throwIO e

libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs

@@ -345,8 +345,8 @@ renderNewClientEmail email name locale Client {..} NewClientEmailTemplate {..} b
     html = renderHtmlWithBranding newClientEmailBodyHtml replace branding
     subj = renderTextWithBranding newClientEmailSubject replace branding
     replace "name" = fromName name
-    replace "label" = fromMaybe "N/A" clientLabel
-    replace "model" = fromMaybe "N/A" clientModel
+    replace "label" = fromMaybe defRequestId clientLabel
+    replace "model" = fromMaybe defRequestId clientModel
     replace "date" =
       formatDateTime
         "%A %e %B %Y, %H:%M - %Z"

libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs

@@ -1,9 +1,9 @@
 module Wire.NotificationSubsystem.InterpreterSpec (spec) where
 
-import Bilge (RequestId (..))
 import Control.Concurrent.Async (async, wait)
 import Control.Exception (throwIO)
 import Data.Data (Proxy (Proxy))
+import Data.Id
 import Data.List.NonEmpty (NonEmpty ((:|)), fromList)
 import Data.List1 qualified as List1
 import Data.Range (fromRange, toRange)
@@ -37,7 +37,7 @@ spec = describe "NotificationSubsystem.Interpreter" do
               { fanoutLimit = toRange $ Proxy @30,
                 chunkSize = 12,
                 slowPushDelay = 0,
-                requestId = RequestId "N/A"
+                requestId = RequestId defRequestId
               }
 
       connId2 <- generate arbitrary
@@ -98,7 +98,7 @@ spec = describe "NotificationSubsystem.Interpreter" do
               { fanoutLimit = toRange $ Proxy @30,
                 chunkSize = 12,
                 slowPushDelay = 0,
-                requestId = RequestId "N/A"
+                requestId = RequestId defRequestId
               }
 
       connId2 <- generate arbitrary
@@ -153,7 +153,7 @@ spec = describe "NotificationSubsystem.Interpreter" do
               { fanoutLimit = toRange $ Proxy @30,
                 chunkSize = 12,
                 slowPushDelay = 1,
-                requestId = RequestId "N/A"
+                requestId = RequestId defRequestId
               }
 
       connId2 <- generate arbitrary
@@ -211,7 +211,7 @@ spec = describe "NotificationSubsystem.Interpreter" do
               { fanoutLimit = toRange $ Proxy @30,
                 chunkSize = 12,
                 slowPushDelay = 1,
-                requestId = RequestId "N/A"
+                requestId = RequestId defRequestId
               }
 
       user1 <- generate arbitrary

services/background-worker/src/Wire/BackendNotificationPusher.hs

@@ -116,7 +116,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do
             ceHttp2Manager <- asks http2Manager
             let ceOriginDomain = notif.ownDomain
                 ceTargetDomain = targetDomain
-                ceOriginRequestId = fromMaybe (RequestId "N/A") notif.requestId
+                ceOriginRequestId = fromMaybe (RequestId defRequestId) notif.requestId
                 cveEnv = FederatorClientEnv {..}
                 cveVersion = Just V0 -- V0 is assumed for non-versioned queue messages
                 fcEnv = FederatorClientVersionedEnv {..}
@@ -135,7 +135,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do
                   ceFederator = federator,
                   ceHttp2Manager = manager,
                   ceOriginRequestId =
-                    fromMaybe (RequestId "N/A") . (.requestId) . NE.head $ bundle.notifications
+                    fromMaybe (RequestId defRequestId) . (.requestId) . NE.head $ bundle.notifications
                 }
         remoteVersions :: Set Int <-
           liftIO
@@ -166,7 +166,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do
             ceHttp2Manager <- asks http2Manager
             let ceOriginDomain = notif.ownDomain
                 ceTargetDomain = targetDomain
-                ceOriginRequestId = fromMaybe (RequestId "N/A") notif.requestId
+                ceOriginRequestId = fromMaybe (RequestId defRequestId) notif.requestId
                 cveEnv = FederatorClientEnv {..}
                 fcEnv = FederatorClientVersionedEnv {..}
             sendNotificationIgnoringVersionMismatch fcEnv notif.targetComponent notif.path notif.body

services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs

@@ -67,7 +67,7 @@ spec = do
                 path = "/on-user-deleted-connections",
                 body = RawJson $ Aeson.encode notifContent,
                 bodyVersions = Nothing,
-                requestId = Just $ RequestId "N/A"
+                requestId = Just $ RequestId defRequestId
               }
       envelope <- newMockEnvelope
       let msg =
@@ -104,7 +104,7 @@ spec = do
       notifContent <-
         generate $
           ClientRemovedRequest <$> arbitrary <*> arbitrary <*> arbitrary
-      let bundle = toBundle @'OnClientRemovedTag (RequestId "N/A") origDomain notifContent
+      let bundle = toBundle @'OnClientRemovedTag (RequestId defRequestId) origDomain notifContent
       envelope <- newMockEnvelope
       let msg =
             Q.newMsg
@@ -148,8 +148,8 @@ spec = do
             }
       let update0 = conversationUpdateToV0 update
       let bundle =
-            toBundle (RequestId "N/A") origDomain update
-              <> toBundle (RequestId "N/A") origDomain update0
+            toBundle (RequestId defRequestId) origDomain update
+              <> toBundle (RequestId defRequestId) origDomain update0
       envelope <- newMockEnvelope
       let msg =
             Q.newMsg
@@ -215,7 +215,7 @@ spec = do
                 path = "/on-user-deleted-connections",
                 body = RawJson $ Aeson.encode notifContent,
                 bodyVersions = Nothing,
-                requestId = Just $ RequestId "N/A"
+                requestId = Just $ RequestId defRequestId
               }
       envelope <- newMockEnvelope
       let msg =

services/brig/src/Brig/App.hs

@@ -92,7 +92,6 @@ module Brig.App
   )
 where
 
-import Bilge (RequestId (..))
 import Bilge qualified as RPC
 import Bilge.IO
 import Bilge.RPC (HasRequestId (..))
@@ -122,6 +121,7 @@ import Control.Monad.Trans.Resource
 import Data.ByteString.Conversion
 import Data.Credentials (Credentials (..))
 import Data.Domain
+import Data.Id
 import Data.Misc
 import Data.Qualified
 import Data.Text qualified as Text
@@ -278,7 +278,7 @@ newEnv opts = do
         awsEnv = aws, -- used by `journalEvent` directly
         appLogger = lgr,
         internalEvents = (eventsQueue :: QueueEnv),
-        requestId = RequestId "N/A",
+        requestId = RequestId defRequestId,
         userTemplates = utp,
         providerTemplates = ptp,
         teamTemplates = ttp,

services/cannon/src/Cannon/App.hs

@@ -29,7 +29,7 @@ import Control.Monad.Catch
 import Data.Aeson hiding (Error, Key, (.=))
 import Data.ByteString.Conversion
 import Data.ByteString.Lazy (toStrict)
-import Data.Id (ClientId)
+import Data.Id
 import Data.Text.Lazy qualified as Text
 import Data.Timeout
 import Imports hiding (threadDelay)
@@ -155,7 +155,7 @@ rejectOnError :: PendingConnection -> HandshakeException -> IO a
 rejectOnError p x = do
   let f lb mg = toStrict . encode $ mkError status400 lb mg
   case x of
-    NotSupported -> rejectRequest p (f "protocol not supported" "N/A")
+    NotSupported -> rejectRequest p (f "protocol not supported" defRequestId)
     MalformedRequest _ m -> rejectRequest p (f "malformed-request" (Text.pack m))
     OtherHandshakeException m -> rejectRequest p (f "other-error" (Text.pack m))
     _ -> pure ()

services/cannon/src/Cannon/Types.hs

@@ -33,7 +33,7 @@ module Cannon.Types
   )
 where
 
-import Bilge (Manager, RequestId (..))
+import Bilge (Manager)
 import Bilge.RPC (HasRequestId (..))
 import Cannon.Dict (Dict)
 import Cannon.Options
@@ -42,6 +42,7 @@ import Cannon.WS qualified as WS
 import Control.Concurrent.Async (mapConcurrently)
 import Control.Lens ((^.))
 import Control.Monad.Catch
+import Data.Id
 import Data.Text.Encoding
 import Imports
 import Prometheus
@@ -100,7 +101,7 @@ mkEnv ::
   Clock ->
   Env
 mkEnv external o l d p g t =
-  Env o l d (RequestId "N/A") $
+  Env o l d (RequestId defRequestId) $
     WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts)
 
 runCannon :: Env -> Cannon a -> IO a

services/cannon/src/Cannon/WS.hs

@@ -62,7 +62,7 @@ import Data.ByteString.Char8 (pack)
 import Data.ByteString.Conversion
 import Data.ByteString.Lazy qualified as L
 import Data.Hashable
-import Data.Id (ClientId, ConnId (..), UserId)
+import Data.Id (ClientId, ConnId (..), UserId, defRequestId)
 import Data.List.Extra (chunksOf)
 import Data.Text.Encoding (decodeUtf8)
 import Data.Timeout (TimeoutUnit (..), (#))
@@ -192,7 +192,7 @@ env ::
   Clock ->
   DrainOpts ->
   Env
-env leh lp gh gp = Env leh lp (host gh . port gp $ empty) (RequestId "N/A")
+env leh lp gh gp = Env leh lp (host gh . port gp $ empty) (RequestId defRequestId)
 
 runWS :: (MonadIO m) => Env -> WS a -> m a
 runWS e m = liftIO $ runReaderT (_conn m) e