[WPB-4406] federator improve logging (#3556)

changelog.d/5-internal/WPB-4406

@@ -0,0 +1,2 @@
+- Extending the information returned in errors for Federator. Paths and response bodies, if available, are included in error logs.
+- Prometheus metrics for outgoing and incoming federation requests added.

integration/integration.cabal

@@ -90,6 +90,7 @@ library
     API.BrigInternal
     API.Cargohold
     API.Common
+    API.Federator
     API.Galley
     API.GalleyInternal
     API.Gundeck

integration/test/API/Federator.hs

@@ -0,0 +1,24 @@
+module API.Federator where
+
+import Data.Function
+import GHC.Stack
+import Network.HTTP.Client qualified as HTTP
+import Testlib.Prelude
+
+getMetrics ::
+  (HasCallStack, MakesValue domain) =>
+  domain ->
+  (ServiceMap -> HostPort) ->
+  App Response
+getMetrics domain service = do
+  req <- rawBaseRequestF domain service "i/metrics"
+  submit "GET" req
+
+rawBaseRequestF :: (HasCallStack, MakesValue domain) => domain -> (ServiceMap -> HostPort) -> String -> App HTTP.Request
+rawBaseRequestF domain getService path = do
+  domainV <- objDomain domain
+  serviceMap <- getServiceMap domainV
+
+  liftIO . HTTP.parseRequest $
+    let HostPort h p = getService serviceMap
+     in "http://" <> h <> ":" <> show p <> ("/" <> joinHttpPath (splitHttpPath path))

integration/test/Test/Federator.hs

@@ -1,36 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Test.Federator where
 
+import API.Brig
+import API.Federator (getMetrics)
+import Data.Attoparsec.Text
 import Data.ByteString qualified as BS
 import Data.String.Conversions
-import Network.HTTP.Client qualified as HTTP
+import Data.Text
+import SetupHelpers (randomUser)
 import Testlib.Prelude
 
 runFederatorMetrics :: (ServiceMap -> HostPort) -> App ()
 runFederatorMetrics getService = do
-  let req = submit "GET" =<< rawBaseRequestF OwnDomain getService "/i/metrics"
-      handleRes res = res <$ res.status `shouldMatchInt` 200
-  first <- bindResponse req handleRes
-  second <- bindResponse req handleRes
+  let handleRes res = res <$ res.status `shouldMatchInt` 200
+  first <- bindResponse (getMetrics OwnDomain getService) handleRes
+  second <- bindResponse (getMetrics OwnDomain getService) handleRes
   assertBool "Two metric requests should never match" $ first.body /= second.body
   assertBool "Second metric response should never be 0 length (the first might be)" $ BS.length second.body /= 0
   assertBool "The seconds metric response should have text indicating that it is returning metrics" $
-    BS.isInfixOf (cs expectedString) second.body
+    BS.isInfixOf expectedString second.body
   where
     expectedString = "# TYPE http_request_duration_seconds histogram"
 
-rawBaseRequestF :: (HasCallStack, MakesValue domain) => domain -> (ServiceMap -> HostPort) -> String -> App HTTP.Request
-rawBaseRequestF domain getService path = do
-  domainV <- objDomain domain
-  serviceMap <- getServiceMap domainV
-
-  liftIO . HTTP.parseRequest $
-    let HostPort h p = getService serviceMap
-     in "http://" <> h <> ":" <> show p <> ("/" <> joinHttpPath (splitHttpPath path))
-
 -- The metrics setup for both internal and external federator servers
 -- are the same, so we can simply run the same test for both.
 testFederatorMetricsInternal :: App ()
 testFederatorMetricsInternal = runFederatorMetrics federatorInternal
 
 testFederatorMetricsExternal :: App ()
 testFederatorMetricsExternal = runFederatorMetrics federatorExternal
+
+testFederatorNumRequestsMetrics :: HasCallStack => App ()
+testFederatorNumRequestsMetrics = do
+  u1 <- randomUser OwnDomain def
+  u2 <- randomUser OtherDomain def
+  incomingBefore <- getMetric parseIncomingRequestCount OtherDomain OwnDomain
+  outgoingBefore <- getMetric parseOutgoingRequestCount OwnDomain OtherDomain
+  bindResponse (searchContacts u1 (u2 %. "name") OtherDomain) $ \resp ->
+    resp.status `shouldMatchInt` 200
+  incomingAfter <- getMetric parseIncomingRequestCount OtherDomain OwnDomain
+  outgoingAfter <- getMetric parseOutgoingRequestCount OwnDomain OtherDomain
+  assertBool "Incoming requests count should have increased by at least 2" $ incomingAfter >= incomingBefore + 2
+  assertBool "Outgoing requests count should have increased by at least 2" $ outgoingAfter >= outgoingBefore + 2
+  where
+    getMetric :: (Text -> Parser Integer) -> Domain -> Domain -> App Integer
+    getMetric p domain origin = do
+      m <- getMetrics domain federatorInternal
+      d <- cs <$> asString origin
+      pure $ fromRight 0 (parseOnly (p d) (cs m.body))
+
+    parseIncomingRequestCount :: Text -> Parser Integer
+    parseIncomingRequestCount d =
+      manyTill anyChar (string ("com_wire_federator_incoming_requests{origin_domain=\"" <> d <> "\"} "))
+        *> decimal
+
+    parseOutgoingRequestCount :: Text -> Parser Integer
+    parseOutgoingRequestCount d =
+      manyTill anyChar (string ("com_wire_federator_outgoing_requests{target_domain=\"" <> d <> "\"} "))
+        *> decimal

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

@@ -31,7 +31,7 @@ import Control.Error
 import Data.Aeson hiding (Error)
 import Data.Aeson.Types (Pair)
 import Data.Domain
-import Data.Text.Lazy.Encoding (decodeUtf8)
+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
 import Imports
 import Network.HTTP.Types
 
@@ -50,23 +50,26 @@ instance Exception Error
 
 data ErrorData = FederationErrorData
   { federrDomain :: !Domain,
-    federrPath :: !Text
+    federrPath :: !Text,
+    federrResp :: !(Maybe LByteString)
   }
   deriving (Eq, Show, Typeable)
 
 instance ToJSON ErrorData where
-  toJSON (FederationErrorData d p) =
+  toJSON (FederationErrorData d p b) =
     object
       [ "type" .= ("federation" :: Text),
         "domain" .= d,
-        "path" .= p
+        "path" .= p,
+        "response" .= fmap decodeUtf8 b
       ]
 
 instance FromJSON ErrorData where
   parseJSON = withObject "ErrorData" $ \o ->
     FederationErrorData
       <$> o .: "domain"
       <*> o .: "path"
+      <*> (fmap encodeUtf8 <$> (o .: "response"))
 
 -- | Assumes UTF-8 encoding.
 byteStringError :: Status -> LByteString -> LByteString -> Error

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

@@ -398,9 +398,10 @@ logErrorMsg (Wai.Error c l m md) =
     . maybe id logErrorData md
     . msg (val "\"" +++ m +++ val "\"")
   where
-    logErrorData (Wai.FederationErrorData d p) =
+    logErrorData (Wai.FederationErrorData d p b) =
       field "domain" (domainText d)
         . field "path" p
+        . field "response" (fromMaybe "" b)
 
 logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg
 logErrorMsgWithRequest mr e =

libs/wire-api-federation/src/Wire/API/Federation/Client.hs

@@ -254,7 +254,8 @@ mkFailureResponse status domain path body
                 { Wai.federrDomain = domain,
                   Wai.federrPath =
                     "/federation"
-                      <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path)
+                      <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path),
+                  Wai.federrResp = pure body
                 }
         }
   where

libs/wire-api-federation/src/Wire/API/Federation/Error.hs

@@ -83,6 +83,7 @@ module Wire.API.Federation.Error
   )
 where
 
+import Data.Domain (Domain (..))
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import Data.Text.Lazy qualified as LT
@@ -206,27 +207,35 @@ federationClientErrorToWai FederatorClientVersionMismatch =
     "internal-error"
     "Endpoint version mismatch in federation client"
 
-federationRemoteHTTP2Error :: FederatorClientHTTP2Error -> Wai.Error
-federationRemoteHTTP2Error FederatorClientNoStatusCode =
-  Wai.mkError
-    unexpectedFederationResponseStatus
-    "federation-http2-error"
-    "No status code in HTTP2 response"
-federationRemoteHTTP2Error (FederatorClientHTTP2Exception e) =
-  Wai.mkError
-    unexpectedFederationResponseStatus
-    "federation-http2-error"
-    (LT.pack (displayException e))
-federationRemoteHTTP2Error (FederatorClientTLSException e) =
-  Wai.mkError
-    (HTTP.mkStatus 525 "SSL Handshake Failure")
-    "federation-tls-error"
-    (LT.pack (displayException e))
-federationRemoteHTTP2Error (FederatorClientConnectionError e) =
-  Wai.mkError
-    federatorConnectionRefusedStatus
-    "federation-connection-refused"
-    (LT.pack (displayException e))
+federationRemoteHTTP2Error :: Domain -> Text -> FederatorClientHTTP2Error -> Wai.Error
+federationRemoteHTTP2Error domain path FederatorClientNoStatusCode =
+  let err =
+        Wai.mkError
+          unexpectedFederationResponseStatus
+          "federation-http2-error"
+          "No status code in HTTP2 response"
+   in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing}
+federationRemoteHTTP2Error domain path (FederatorClientHTTP2Exception e) =
+  let err =
+        Wai.mkError
+          unexpectedFederationResponseStatus
+          "federation-http2-error"
+          (LT.pack (displayException e))
+   in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing}
+federationRemoteHTTP2Error domain path (FederatorClientTLSException e) =
+  let err =
+        Wai.mkError
+          (HTTP.mkStatus 525 "SSL Handshake Failure")
+          "federation-tls-error"
+          (LT.pack (displayException e))
+   in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing}
+federationRemoteHTTP2Error domain path (FederatorClientConnectionError e) =
+  let err =
+        Wai.mkError
+          federatorConnectionRefusedStatus
+          "federation-connection-refused"
+          (LT.pack (displayException e))
+   in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing}
 
 federationClientHTTP2Error :: FederatorClientHTTP2Error -> Wai.Error
 federationClientHTTP2Error (FederatorClientConnectionError e) =
@@ -240,14 +249,21 @@ federationClientHTTP2Error e =
     "federation-local-error"
     (LT.pack (displayException e))
 
-federationRemoteResponseError :: HTTP.Status -> Wai.Error
-federationRemoteResponseError status =
-  Wai.mkError
-    unexpectedFederationResponseStatus
-    "federation-remote-error"
-    ( "A remote federator failed with status code "
-        <> LT.pack (show (HTTP.statusCode status))
-    )
+federationRemoteResponseError :: Domain -> Text -> HTTP.Status -> LByteString -> Wai.Error
+federationRemoteResponseError domain path status resp =
+  err
+    { Wai.errorData = pure $ Wai.FederationErrorData domain path $ pure resp
+    }
+  where
+    err =
+      Wai.mkError
+        unexpectedFederationResponseStatus
+        "federation-remote-error"
+        ( "A remote federator ("
+            <> LT.fromStrict domain._domainText
+            <> ") failed with status code "
+            <> LT.pack (show (HTTP.statusCode status))
+        )
 
 federationServantErrorToWai :: ClientError -> Wai.Error
 federationServantErrorToWai (DecodeFailure msg _) = federationInvalidBody msg

services/federator/default.nix

@@ -41,6 +41,7 @@
 , pem
 , polysemy
 , polysemy-wire-zoo
+, prometheus-client
 , QuickCheck
 , random
 , servant
@@ -105,6 +106,7 @@ mkDerivation {
     pem
     polysemy
     polysemy-wire-zoo
+    prometheus-client
     servant
     servant-client-core
     servant-server

services/federator/federator.cabal

@@ -43,6 +43,7 @@ library
     Federator.ExternalServer
     Federator.Health
     Federator.InternalServer
+    Federator.Metrics
     Federator.MockServer
     Federator.Monitor
     Federator.Monitor.Internal
@@ -134,6 +135,7 @@ library
     , pem
     , polysemy
     , polysemy-wire-zoo
+    , prometheus-client
     , servant
     , servant-client-core
     , servant-server

services/federator/src/Federator/Env.hs

@@ -30,11 +30,17 @@ import Imports
 import Network.DNS.Resolver (Resolver)
 import Network.HTTP.Client qualified as HTTP
 import OpenSSL.Session (SSLContext)
+import Prometheus
 import System.Logger.Class qualified as LC
 import Util.Options
 import Wire.API.Federation.Component
 import Wire.API.Routes.FederationDomainConfig (FederationDomainConfigs)
 
+data FederatorMetrics = FederatorMetrics
+  { outgoingRequests :: Vector Text Counter,
+    incomingRequests :: Vector Text Counter
+  }
+
 data Env = Env
   { _metrics :: Metrics,
     _applog :: LC.Logger,
@@ -46,7 +52,8 @@ data Env = Env
     _externalPort :: Word16,
     _internalPort :: Word16,
     _httpManager :: HTTP.Manager,
-    _http2Manager :: IORef Http2Manager
+    _http2Manager :: IORef Http2Manager,
+    _federatorMetrics :: FederatorMetrics
   }
 
 makeLenses ''Env

services/federator/src/Federator/ExternalServer.hs

@@ -40,6 +40,7 @@ import Federator.Discovery
 import Federator.Env
 import Federator.Error.ServerError
 import Federator.Health qualified as Health
+import Federator.Metrics
 import Federator.RPC
 import Federator.Response
 import Federator.Service
@@ -103,7 +104,8 @@ server ::
     Member (Error ValidationError) r,
     Member (Error DiscoveryFailure) r,
     Member (Error ServerError) r,
-    Member (Input FederationDomainConfigs) r
+    Member (Input FederationDomainConfigs) r,
+    Member Metrics r
   ) =>
   Manager ->
   Word16 ->
@@ -125,7 +127,8 @@ callInward ::
     Member (Error ValidationError) r,
     Member (Error DiscoveryFailure) r,
     Member (Error ServerError) r,
-    Member (Input FederationDomainConfigs) r
+    Member (Input FederationDomainConfigs) r,
+    Member Metrics r
   ) =>
   Component ->
   RPC ->
@@ -134,6 +137,7 @@ callInward ::
   Wai.Request ->
   Sem r Wai.Response
 callInward component (RPC rpc) originDomain (CertHeader cert) wreq = do
+  incomingCounterIncr originDomain
   -- only POST is supported
   when (Wai.requestMethod wreq /= HTTP.methodPost) $
     throw InvalidRoute