From 1357e7070d027f5b96de25c27b64927c24183a95 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 6 Dec 2023 14:26:44 +0000 Subject: [PATCH 01/20] wip --- integration/test/API/Brig.hs | 4 +++- integration/test/Test/Search.hs | 12 ++++++++++++ libs/types-common/src/Data/Id.hs | 3 +++ .../src/Wire/API/Federation/Client.hs | 5 ++++- .../src/Wire/BackendNotificationPusher.hs | 1 + services/brig/src/Brig/Federation/Client.hs | 4 +++- services/cargohold/src/CargoHold/Federation.hs | 4 +++- services/federator/federator.cabal | 1 + services/federator/src/Federator/ExternalServer.hs | 13 +++++++++---- services/federator/src/Federator/InternalServer.hs | 10 +++++++--- services/federator/src/Federator/MockServer.hs | 2 +- services/federator/src/Federator/Remote.hs | 7 +++++-- services/federator/src/Federator/Service.hs | 10 +++++----- .../test/integration/Test/Federator/IngressSpec.hs | 2 +- .../federator/test/unit/Test/Federator/Client.hs | 14 +++++++++++--- .../test/unit/Test/Federator/ExternalServer.hs | 8 ++++---- .../test/unit/Test/Federator/InternalServer.hs | 6 +++--- .../federator/test/unit/Test/Federator/Remote.hs | 2 +- services/galley/src/Galley/Intra/Federator.hs | 4 +++- 19 files changed, 80 insertions(+), 32 deletions(-) diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 8e1c390862a..8a99c9b5131 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -6,6 +6,7 @@ import Data.ByteString.Base64 qualified as Base64 import Data.Foldable import Data.Function import Data.Text.Encoding qualified as T +import Data.UUID.V1 (nextUUID) import GHC.Stack import Testlib.Prelude @@ -206,10 +207,11 @@ searchContacts :: domain -> App Response searchContacts user searchTerm domain = do + rid <- show . fromJust <$> liftIO nextUUID req <- baseRequest user Brig Versioned "/search/contacts" q <- asString searchTerm d <- objDomain domain - submit "GET" (req & addQueryParams [("q", q), ("domain", d)]) + submit "GET" (req & addQueryParams [("q", q), ("domain", d)] & addHeader "Request-Id" rid) getAPIVersion :: (HasCallStack, MakesValue domain) => domain -> App Response getAPIVersion domain = do diff --git a/integration/test/Test/Search.hs b/integration/test/Test/Search.hs index 955afd744f1..3e6dcf5b122 100644 --- a/integration/test/Test/Search.hs +++ b/integration/test/Test/Search.hs @@ -217,3 +217,15 @@ testFederatedUserSearchForNonTeamUser = do [] -> pure () doc : _ -> assertFailure $ "Expected an empty result, but got " <> show doc <> " for test case " + + +testRequestIdFederatedUserSearch :: HasCallStack => App () +testRequestIdFederatedUserSearch = do + let testCases = + [ + FedUserSearchTestCase "full_search" AllowAll AllowAll True True + ] + startDynamicBackends [def, def] $ \[d1, d2] -> do + void $ BrigI.createFedConn d2 (BrigI.FedConn d1 "full_search" Nothing) + void $ BrigI.createFedConn d1 (BrigI.FedConn d2 "full_search" Nothing) + forM_ testCases (federatedUserSearch d1 d2) diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 5bc62d4ca59..e10ae9bd453 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -437,6 +437,9 @@ instance EncodeWire RequestId where instance DecodeWire RequestId where decodeWire = fmap RequestId . decodeWire +instance FromHttpApiData RequestId where + parseUrlPiece = Right . RequestId . encodeUtf8 + -- Rendering Id values in JSON objects ----------------------------------------- newtype IdObject a = IdObject {fromIdObject :: a} diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index b27b833b2e7..642093e7852 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -45,6 +45,7 @@ import Data.ByteString.Builder import Data.ByteString.Conversion (toByteString') import Data.ByteString.Lazy qualified as LBS import Data.Domain +import Data.Id import Data.Sequence qualified as Seq import Data.Set qualified as Set import Data.Text.Encoding qualified as Text @@ -74,7 +75,8 @@ data FederatorClientEnv = FederatorClientEnv { ceOriginDomain :: Domain, ceTargetDomain :: Domain, ceFederator :: Endpoint, - ceHttp2Manager :: Http2Manager + ceHttp2Manager :: Http2Manager, + ceOriginRequestId :: RequestId } data FederatorClientVersionedEnv = FederatorClientVersionedEnv @@ -215,6 +217,7 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do toList (requestHeaders req) <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))] <> [(HTTP.hAccept, HTTP.renderHeader (toList $ req.requestAccept))] + <> [("Wire-Origin-Request-Id", toByteString' (ceOriginRequestId env))] req' = HTTP2.requestBuilder (requestMethod req) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 3bcceafac4c..67248a04ca0 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -96,6 +96,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do ceHttp2Manager <- asks http2Manager let ceOriginDomain = notif.ownDomain ceTargetDomain = targetDomain + ceOriginRequestId = error "todo(leif): requestId not set" fcEnv = FederatorClientEnv {..} liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body lift $ ack envelope diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 87c44ec4465..9c3d2b6f6b2 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -192,12 +192,14 @@ runBrigFederatorClient targetDomain action = do ownDomain <- viewFederationDomain endpoint <- view federator >>= maybe (throwE FederationNotConfigured) pure mgr <- view http2Manager + rid <- view requestId let env = FederatorClientEnv { ceOriginDomain = ownDomain, ceTargetDomain = targetDomain, ceFederator = endpoint, - ceHttp2Manager = mgr + ceHttp2Manager = mgr, + ceOriginRequestId = rid } liftIO (runFederatorClient env action) >>= either (throwE . FederationCallFailure) pure diff --git a/services/cargohold/src/CargoHold/Federation.hs b/services/cargohold/src/CargoHold/Federation.hs index d1d57d0a5bf..7ce7d4aae6b 100644 --- a/services/cargohold/src/CargoHold/Federation.hs +++ b/services/cargohold/src/CargoHold/Federation.hs @@ -80,12 +80,14 @@ mkFederatorClientEnv remote = do view (options . federator) >>= maybe (throwE federationNotConfigured) pure mgr <- view http2Manager + rid <- view requestId pure FederatorClientEnv { ceOriginDomain = tDomain loc, ceTargetDomain = tDomain remote, ceFederator = endpoint, - ceHttp2Manager = mgr + ceHttp2Manager = mgr, + ceOriginRequestId = rid } executeFederated :: Remote x -> FederatorClient 'Cargohold a -> Handler a diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 76f746e3a8c..a451aa24bea 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -413,6 +413,7 @@ test-suite federator-tests , transformers , types-common , unix + , uuid , wai , wai-extra , wai-utilities diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index 733a838b8be..9c47d0f3513 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -30,6 +30,7 @@ import Data.ByteString qualified as BS import Data.ByteString.Builder import Data.ByteString.Lazy qualified as LBS import Data.Domain +import Data.Id (RequestId) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) import Data.Sequence qualified as Seq @@ -86,6 +87,7 @@ data API mode = API :- "federation" :> Capture "component" Component :> Capture "rpc" RPC + :> Header "Wire-Origin-Request-Id" RequestId :> Header' '[Required, Strict] OriginDomainHeaderName Domain :> Header' '[Required, Strict] "X-SSL-Certificate" CertHeader :> Endpath @@ -114,8 +116,8 @@ server :: server mgr intPort interpreter = API { status = Health.status mgr "internal server" intPort, - externalRequest = \component rpc remoteDomain remoteCert -> - Tagged $ \req respond -> runCodensity (interpreter (callInward component rpc remoteDomain remoteCert req)) respond + externalRequest = \component rpc mReqId remoteDomain remoteCert -> + Tagged $ \req respond -> runCodensity (interpreter (callInward component rpc mReqId remoteDomain remoteCert req)) respond } -- FUTUREWORK(federation): Versioning of the federation API. @@ -132,11 +134,12 @@ callInward :: ) => Component -> RPC -> + Maybe RequestId -> Domain -> CertHeader -> Wai.Request -> Sem r Wai.Response -callInward component (RPC rpc) originDomain (CertHeader cert) wreq = do +callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do incomingCounterIncr originDomain -- only POST is supported when (Wai.requestMethod wreq /= HTTP.methodPost) $ @@ -151,16 +154,18 @@ callInward component (RPC rpc) originDomain (CertHeader cert) wreq = do . Log.field "originDomain" (domainText originDomain) . Log.field "component" (show component) . Log.field "rpc" rpc + . Log.field "requestId" (maybe "N/A" show mReqId) validatedDomain <- validateDomain cert originDomain let path = LBS.toStrict (toLazyByteString (HTTP.encodePathSegments ["federation", rpc])) body <- embed $ Wai.lazyRequestBody wreq - resp <- serviceCall component path body validatedDomain + resp <- serviceCall component path body mReqId validatedDomain Log.debug $ Log.msg ("Inward Request response" :: ByteString) . Log.field "status" (show (responseStatusCode resp)) + . Log.field "requestId" (maybe "N/A" show mReqId) pure $ streamingResponseToWai resp diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index b9e3d903a36..6c8ea979a5e 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -24,6 +24,7 @@ import Control.Monad.Codensity import Data.Binary.Builder import Data.ByteString qualified as BS import Data.Domain +import Data.Id import Data.Metrics.Servant qualified as Metrics import Data.Proxy import Federator.Env @@ -62,6 +63,7 @@ data API mode = API internalRequest :: mode :- "rpc" + :> Header "Wire-Origin-Request-Id" RequestId :> Capture "domain" Domain :> Capture "component" Component :> Capture "rpc" RPC @@ -89,8 +91,8 @@ server :: server mgr extPort interpreter = API { status = Health.status mgr "external server" extPort, - internalRequest = \remoteDomain component rpc -> - Tagged $ \req respond -> runCodensity (interpreter (callOutward remoteDomain component rpc req)) respond + internalRequest = \mReqId remoteDomain component rpc -> + Tagged $ \req respond -> runCodensity (interpreter (callOutward mReqId remoteDomain component rpc req)) respond } callOutward :: @@ -102,12 +104,13 @@ callOutward :: Member Metrics r, Member (Logger (Log.Msg -> Log.Msg)) r ) => + Maybe RequestId -> Domain -> Component -> RPC -> Wai.Request -> Sem r Wai.Response -callOutward targetDomain component (RPC path) req = do +callOutward mReqId targetDomain component (RPC path) req = do -- only POST is supported when (Wai.requestMethod req /= HTTP.methodPost) $ throw InvalidRoute @@ -125,6 +128,7 @@ callOutward targetDomain component (RPC path) req = do . Log.field "body" body resp <- discoverAndCall + mReqId targetDomain component path diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index 2f2fd2be656..1c0832e52f5 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -114,7 +114,7 @@ mockServer :: mockServer remoteCalls headers resp interpreter = Federator.InternalServer.API { status = const $ pure NoContent, - internalRequest = \targetDomain component rpc -> + internalRequest = \_mReqId targetDomain component rpc -> Tagged $ \req respond -> respond =<< interpreter (mockInternalRequest remoteCalls headers resp targetDomain component rpc req) } diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 3741bad1bf9..4e362d67062 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -26,11 +26,13 @@ module Federator.Remote ) where +import Bilge.Request qualified as RPC import Control.Exception qualified as E import Control.Monad.Codensity import Data.Binary.Builder import Data.ByteString.Lazy qualified as LBS import Data.Domain +import Data.Id import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8) import Data.Text.Encoding qualified as Text @@ -96,6 +98,7 @@ displayTarget (SrvTarget hostname port) = data Remote m a where DiscoverAndCall :: + Maybe RequestId -> Domain -> Component -> Text -> @@ -115,14 +118,14 @@ interpretRemote :: Sem (Remote ': r) a -> Sem r a interpretRemote = interpret $ \case - DiscoverAndCall domain component rpc headers body -> do + DiscoverAndCall mReqId domain component rpc headers body -> do target@(SrvTarget hostname port) <- discoverFederatorWithError domain let path = LBS.toStrict . toLazyByteString $ HTTP.encodePathSegments ["federation", componentName component, rpc] pathT = decodeUtf8 path -- filter out Host header, because the HTTP2 client adds it back - headers' = filter ((/= "Host") . fst) headers + headers' = filter ((/= "Host") . fst) headers <> [((RPC.requestIdName, maybe "N/A" RPC.unRequestId mReqId))] req' = HTTP2.requestBuilder HTTP.methodPost path headers' body mgr <- input diff --git a/services/federator/src/Federator/Service.hs b/services/federator/src/Federator/Service.hs index 40553e77b23..b92d787cf77 100644 --- a/services/federator/src/Federator/Service.hs +++ b/services/federator/src/Federator/Service.hs @@ -33,6 +33,7 @@ import Control.Lens (view) import Control.Monad.Codensity import Data.ByteString qualified as BS import Data.Domain +import Data.Id import Data.Sequence qualified as Seq import Data.Text.Encoding qualified as Text import Federator.Env @@ -51,7 +52,7 @@ type ServiceStreaming = Service (SourceT IO ByteString) data Service body m a where -- | Returns status, headers and body, 'HTTP.Response' is not nice to work with in tests - ServiceCall :: Component -> ByteString -> LByteString -> Domain -> Service body m (Servant.ResponseF body) + ServiceCall :: Component -> ByteString -> LByteString -> Maybe RequestId -> Domain -> Service body m (Servant.ResponseF body) makeSem ''Service @@ -80,10 +81,9 @@ interpretServiceHTTP :: Sem (ServiceStreaming ': r) a -> Sem r a interpretServiceHTTP = interpret $ \case - ServiceCall component rpcPath body domain -> do + ServiceCall component rpcPath body mReqId domain -> do Endpoint serviceHost servicePort <- inputs (view service) <*> pure component manager <- inputs (view httpManager) - reqId <- inputs (view requestId) let req = defaultRequest { method = HTTP.methodPost, @@ -93,9 +93,9 @@ interpretServiceHTTP = interpret $ \case path = rpcPath, requestHeaders = [ ("Content-Type", "application/json"), - (originDomainHeaderName, cs (domainText domain)), - (RPC.requestIdName, RPC.unRequestId reqId) + (originDomainHeaderName, cs (domainText domain)) ] + <> maybe [] (\(RequestId rid) -> [(RPC.requestIdName, rid)]) mReqId } embed $ diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 0d322238276..84d08fbd354 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -151,4 +151,4 @@ inwardBrigCallViaIngressWithSettings sslCtx requestPath payload = . assertNoError @DiscoveryFailure . discoverConst target . interpretRemote - $ discoverAndCall (Domain "example.com") Brig requestPath headers payload + $ discoverAndCall Nothing (Domain "example.com") Brig requestPath headers payload diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index d5db3ae77f6..f7eb01b209b 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -27,8 +27,10 @@ import Data.ByteString qualified as BS import Data.ByteString.Builder (Builder, byteString, toLazyByteString) import Data.ByteString.Lazy qualified as LBS import Data.Domain +import Data.Id (RequestId (RequestId)) import Data.Proxy import Data.Text.Encoding qualified as Text +import Data.UUID.V1 (nextUUID) import Federator.MockServer import HTTP2.Client.Manager (defaultHttp2Manager, withHTTP2Request) import Imports @@ -92,12 +94,14 @@ withMockFederatorClient :: IO (Either ResponseFailure a, [FederatedRequest]) withMockFederatorClient headers resp action = withTempMockFederator headers resp $ \port -> do mgr <- defaultHttp2Manager + rid <- RequestId . cs . show . fromJust <$> liftIO nextUUID let env = FederatorClientEnv { ceOriginDomain = originDomain, ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), - ceHttp2Manager = mgr + ceHttp2Manager = mgr, + ceOriginRequestId = rid } a <- runFederatorClient env action case a of @@ -132,12 +136,14 @@ type StreamingAPI = StreamGet NewlineFraming PlainText (SourceIO Text) testClientStreaming :: IO () testClientStreaming = withInfiniteMockServer $ \port -> do mgr <- defaultHttp2Manager + rid <- RequestId . cs . show . fromJust <$> liftIO nextUUID let env = FederatorClientEnv { ceOriginDomain = originDomain, ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), - ceHttp2Manager = mgr + ceHttp2Manager = mgr, + ceOriginRequestId = rid } venv = FederatorClientVersionedEnv env Nothing let c = clientIn (Proxy @StreamingAPI) (Proxy @(FederatorClient 'Brig)) @@ -198,12 +204,14 @@ testClientConnectionError :: IO () testClientConnectionError = do handle <- generate arbitrary mgr <- defaultHttp2Manager + rid <- RequestId . cs . show . fromJust <$> liftIO nextUUID let env = FederatorClientEnv { ceOriginDomain = originDomain, ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" 1, - ceHttp2Manager = mgr + ceHttp2Manager = mgr, + ceOriginRequestId = rid } result <- runFederatorClient env (fedClient @'Brig @"get-user-by-handle" handle) case result of diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index 66961412305..2cfe4a49307 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -101,7 +101,7 @@ mockService :: Sem (ServiceStreaming ': r) a -> Sem r a mockService status = interpret $ \case - ServiceCall comp path body domain -> do + ServiceCall comp path body _mReqId domain -> do output (Call comp path body domain) pure Servant.Response @@ -137,7 +137,7 @@ requestBrigSuccess = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls Wai.responseStatus res @?= HTTP.status200 @@ -165,7 +165,7 @@ requestBrigFailure = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls @@ -195,7 +195,7 @@ requestGalleySuccess = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Galley (RPC "get-conversations") aValidDomain (CertHeader cert) request + $ callInward Galley (RPC "get-conversations") Nothing aValidDomain (CertHeader cert) request let expectedCall = Call Galley "/federation/get-conversations" "\"foo\"" aValidDomain embed $ assertEqual "one call to galley should be made" [expectedCall] actualCalls embed $ Wai.responseStatus res @?= HTTP.status200 diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index ddb48b8c984..3fb41d2d869 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -74,7 +74,7 @@ federatedRequestSuccess = } let interpretCall :: Member (Embed IO) r => Sem (Remote ': r) a -> Sem r a interpretCall = interpret $ \case - DiscoverAndCall domain component rpc headers body -> embed @IO $ do + DiscoverAndCall _ domain component rpc headers body -> embed @IO $ do domain @?= targetDomain component @?= Brig rpc @?= "get-user-by-handle" @@ -102,7 +102,7 @@ federatedRequestSuccess = . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "target.example.com") FullSearch FederationRestrictionAllowAll] 10) . assertMetrics - $ callOutward targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request Wai.responseStatus res @?= HTTP.status200 body <- Wai.lazyResponseBody res body @?= "\"bar\"" @@ -148,7 +148,7 @@ federatedRequestFailureAllowList = . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "hello.world") FullSearch FederationRestrictionAllowAll] 10) . interpretMetricsEmpty - $ callOutward targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request eith @?= Left (FederationDenied targetDomain) -- @END diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 5f82cea2753..7d7ec063733 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -89,7 +89,7 @@ mkTestCall sslCtx hostname port = do . discoverLocalhost hostname port . assertNoError @DiscoveryFailure . interpretRemote - $ discoverAndCall (Domain "localhost") Brig "test" [] mempty + $ discoverAndCall Nothing (Domain "localhost") Brig "test" [] mempty withMockServer :: Warp.TLSSettings -> (Warp.Port -> IO a) -> IO a withMockServer tls k = diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index e0ac966dcba..6e09422c98a 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -59,6 +59,7 @@ runFederatedEither (tDomain -> remoteDomain) rpc = do ownDomain <- view (options . settings . federationDomain) mfedEndpoint <- view E.federator mgr <- view http2Manager + rid <- view reqId case mfedEndpoint of Nothing -> pure (Left FederationNotConfigured) Just fedEndpoint -> do @@ -67,7 +68,8 @@ runFederatedEither (tDomain -> remoteDomain) rpc = do { ceOriginDomain = ownDomain, ceTargetDomain = remoteDomain, ceFederator = fedEndpoint, - ceHttp2Manager = mgr + ceHttp2Manager = mgr, + ceOriginRequestId = rid } liftIO . fmap (first FederationCallFailure) $ runFederatorClient ce rpc From 0991bec2b8de387519e5b0e2f7b108c76e08f6a1 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 6 Dec 2023 15:17:00 +0000 Subject: [PATCH 02/20] add req id to notifications --- .../src/Wire/API/Federation/API.hs | 2 +- .../Wire/API/Federation/BackendNotifications.hs | 15 ++++++++++----- .../API/Federation/HasNotificationEndpoint.hs | 7 +++++-- .../Test/Wire/BackendNotificationPusherSpec.hs | 6 ++++-- services/brig/src/Brig/Federation/Client.hs | 11 +++++++---- services/federator/src/Federator/Remote.hs | 4 +++- services/federator/src/Federator/Service.hs | 2 +- .../src/Galley/Intra/BackendNotificationQueue.hs | 5 ++++- 8 files changed, 35 insertions(+), 17 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index a5d7c71d036..9d1b1ef1241 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -93,7 +93,7 @@ fedQueueClient :: FedQueueClient (NotificationComponent k) () fedQueueClient payload = do env <- ask - let notif = fedNotifToBackendNotif @tag env.originDomain payload + let notif = fedNotifToBackendNotif @tag env.requestId env.originDomain payload msg = newMsg { msgBody = encode notif, diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 6ad8ddde899..7094ab798a5 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -7,6 +7,7 @@ import Control.Exception import Control.Monad.Except import Data.Aeson import Data.Domain +import Data.Id (RequestId) import Data.Map qualified as Map import Data.Text qualified as Text import Data.Text.Lazy.Encoding qualified as TL @@ -31,7 +32,8 @@ data BackendNotification = BackendNotification -- this body, which could be very large and completely useless to the -- pusher. This also makes development less clunky as we don't have to -- create a sum type here for all types of notifications that could exist. - body :: RawJson + body :: RawJson, + requestId :: Maybe RequestId } deriving (Show, Eq) @@ -41,7 +43,8 @@ instance ToJSON BackendNotification where [ "ownDomain" .= notif.ownDomain, "targetComponent" .= notif.targetComponent, "path" .= notif.path, - "body" .= TL.decodeUtf8 notif.body.rawJsonBytes + "body" .= TL.decodeUtf8 notif.body.rawJsonBytes, + "requestId" .= notif.requestId ] instance FromJSON BackendNotification where @@ -51,6 +54,7 @@ instance FromJSON BackendNotification where <*> o .: "targetComponent" <*> o .: "path" <*> (RawJson . TL.encodeUtf8 <$> o .: "body") + <*> o .:? "requestId" type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse @@ -70,8 +74,8 @@ sendNotification env component path body = runFederatorClient env . void $ clientIn (Proxy @BackendNotificationAPI) (Proxy @(FederatorClient c)) (withoutFirstSlash path) body -enqueue :: Q.Channel -> Domain -> Domain -> Q.DeliveryMode -> FedQueueClient c a -> IO a -enqueue channel originDomain targetDomain deliveryMode (FedQueueClient action) = +enqueue :: Q.Channel -> Maybe RequestId -> Domain -> Domain -> Q.DeliveryMode -> FedQueueClient c a -> IO a +enqueue channel requestId originDomain targetDomain deliveryMode (FedQueueClient action) = runReaderT action FedQueueEnv {..} routingKey :: Text -> Text @@ -127,7 +131,8 @@ data FedQueueEnv = FedQueueEnv { channel :: Q.Channel, originDomain :: Domain, targetDomain :: Domain, - deliveryMode :: Q.DeliveryMode + deliveryMode :: Q.DeliveryMode, + requestId :: Maybe RequestId } data EnqueueError = EnqueueError String diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index c698d39c14d..9ff326186cf 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -19,6 +19,7 @@ module Wire.API.Federation.HasNotificationEndpoint where import Data.Aeson import Data.Domain +import Data.Id import Data.Kind import Data.Proxy import Data.Text qualified as T @@ -46,10 +47,11 @@ fedNotifToBackendNotif :: KnownSymbol (NotificationPath tag) => KnownComponent (NotificationComponent k) => ToJSON (Payload tag) => + Maybe RequestId -> Domain -> Payload tag -> BackendNotification -fedNotifToBackendNotif ownDomain payload = +fedNotifToBackendNotif mReqId ownDomain payload = let p = T.pack . symbolVal $ Proxy @(NotificationPath tag) b = RawJson . encode $ payload in toNotif p b @@ -60,5 +62,6 @@ fedNotifToBackendNotif ownDomain payload = { ownDomain = ownDomain, targetComponent = componentVal @(NotificationComponent k), path = path, - body = body + body = body, + requestId = mReqId } diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 243eb3d864b..ae926d37b74 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -62,7 +62,8 @@ spec = do { targetComponent = Brig, ownDomain = origDomain, path = "/on-user-deleted-connections", - body = RawJson $ Aeson.encode notifContent + body = RawJson $ Aeson.encode notifContent, + requestId = Nothing } envelope <- newMockEnvelope let msg = @@ -128,7 +129,8 @@ spec = do { targetComponent = Brig, ownDomain = origDomain, path = "/on-user-deleted-connections", - body = RawJson $ Aeson.encode notifContent + body = RawJson $ Aeson.encode notifContent, + requestId = Nothing } envelope <- newMockEnvelope let msg = diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 9c3d2b6f6b2..4570563dae7 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -18,7 +18,7 @@ -- FUTUREWORK: Remove this module all together. module Brig.Federation.Client where -import Brig.App +import Brig.App as Brig import Control.Lens import Control.Monad import Control.Monad.Catch (MonadMask, throwM) @@ -161,22 +161,25 @@ notifyUserDeleted self remotes = do . Log.field "error" (show FederationNotConfigured) -- | Enqueues notifications in RabbitMQ. Retries 3 times with a delay of 1s. -enqueueNotification :: (MonadIO m, MonadMask m, Log.MonadLogger m) => Domain -> Domain -> Q.DeliveryMode -> MVar Q.Channel -> FedQueueClient c () -> m () +enqueueNotification :: (MonadIO m, MonadMask m, Log.MonadLogger m, MonadReader Env m) => Domain -> Domain -> Q.DeliveryMode -> MVar Q.Channel -> FedQueueClient c () -> m () enqueueNotification ownDomain remoteDomain deliveryMode chanVar action = do let policy = limitRetries 3 <> constantDelay 1_000_000 recovering policy [logRetries (const $ pure True) logError] (const go) where logError willRetry (SomeException e) status = do + rid <- view Brig.requestId Log.err $ Log.msg @Text "failed to enqueue notification in RabbitMQ" . Log.field "error" (displayException e) . Log.field "willRetry" willRetry . Log.field "retryCount" status.rsIterNumber + . Log.field "requestId" (show rid) go = do + rid <- view Brig.requestId mChan <- timeout (1 :: Second) (readMVar chanVar) case mChan of Nothing -> throwM NoRabbitMqChannel - Just chan -> liftIO $ enqueue chan ownDomain remoteDomain deliveryMode action + Just chan -> liftIO $ enqueue chan (Just rid) ownDomain remoteDomain deliveryMode action data NoRabbitMqChannel = NoRabbitMqChannel deriving (Show) @@ -192,7 +195,7 @@ runBrigFederatorClient targetDomain action = do ownDomain <- viewFederationDomain endpoint <- view federator >>= maybe (throwE FederationNotConfigured) pure mgr <- view http2Manager - rid <- view requestId + rid <- view Brig.requestId let env = FederatorClientEnv { ceOriginDomain = ownDomain, diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 4e362d67062..6ec9242f440 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -125,7 +125,9 @@ interpretRemote = interpret $ \case HTTP.encodePathSegments ["federation", componentName component, rpc] pathT = decodeUtf8 path -- filter out Host header, because the HTTP2 client adds it back - headers' = filter ((/= "Host") . fst) headers <> [((RPC.requestIdName, maybe "N/A" RPC.unRequestId mReqId))] + headers' = + filter ((/= "Host") . fst) headers + <> [(RPC.requestIdName, rid) | RequestId rid <- maybeToList mReqId] req' = HTTP2.requestBuilder HTTP.methodPost path headers' body mgr <- input diff --git a/services/federator/src/Federator/Service.hs b/services/federator/src/Federator/Service.hs index b92d787cf77..d22d91929c8 100644 --- a/services/federator/src/Federator/Service.hs +++ b/services/federator/src/Federator/Service.hs @@ -95,7 +95,7 @@ interpretServiceHTTP = interpret $ \case [ ("Content-Type", "application/json"), (originDomainHeaderName, cs (domainText domain)) ] - <> maybe [] (\(RequestId rid) -> [(RPC.requestIdName, rid)]) mReqId + <> [(RPC.requestIdName, rid) | RequestId rid <- maybeToList mReqId] } embed $ diff --git a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs index 411897a0834..1c0b8cc4d6a 100644 --- a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs +++ b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs @@ -46,17 +46,20 @@ enqueueSingleNotification remoteDomain deliveryMode chanVar action = do recovering policy handlers (const $ go ownDomain) where logError willRetry (SomeException e) status = do + rid <- view reqId Log.err $ Log.msg @Text "failed to enqueue notification in RabbitMQ" . Log.field "error" (displayException e) . Log.field "willRetry" willRetry . Log.field "retryCount" status.rsIterNumber + . Log.field "request" (show rid) go ownDomain = do + rid <- view reqId mChan <- timeout 1_000_000 (readMVar chanVar) case mChan of Nothing -> throwM NoRabbitMqChannel Just chan -> do - liftIO $ enqueue chan ownDomain remoteDomain deliveryMode action + liftIO $ enqueue chan (Just rid) ownDomain remoteDomain deliveryMode action enqueueNotification :: Domain -> Q.DeliveryMode -> FedQueueClient c a -> ExceptT FederationError App a enqueueNotification remoteDomain deliveryMode action = do From d24b051335d295092835515fd29dc9c002e3361c Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 6 Dec 2023 15:27:49 +0000 Subject: [PATCH 03/20] clean up --- integration/test/API/Brig.hs | 4 +--- integration/test/Test/Search.hs | 12 ------------ libs/types-common/src/Data/Id.hs | 4 +++- services/brig/src/Brig/Federation/Client.hs | 2 +- .../src/Galley/Intra/BackendNotificationQueue.hs | 2 +- 5 files changed, 6 insertions(+), 18 deletions(-) diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 8a99c9b5131..8e1c390862a 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -6,7 +6,6 @@ import Data.ByteString.Base64 qualified as Base64 import Data.Foldable import Data.Function import Data.Text.Encoding qualified as T -import Data.UUID.V1 (nextUUID) import GHC.Stack import Testlib.Prelude @@ -207,11 +206,10 @@ searchContacts :: domain -> App Response searchContacts user searchTerm domain = do - rid <- show . fromJust <$> liftIO nextUUID req <- baseRequest user Brig Versioned "/search/contacts" q <- asString searchTerm d <- objDomain domain - submit "GET" (req & addQueryParams [("q", q), ("domain", d)] & addHeader "Request-Id" rid) + submit "GET" (req & addQueryParams [("q", q), ("domain", d)]) getAPIVersion :: (HasCallStack, MakesValue domain) => domain -> App Response getAPIVersion domain = do diff --git a/integration/test/Test/Search.hs b/integration/test/Test/Search.hs index 3e6dcf5b122..955afd744f1 100644 --- a/integration/test/Test/Search.hs +++ b/integration/test/Test/Search.hs @@ -217,15 +217,3 @@ testFederatedUserSearchForNonTeamUser = do [] -> pure () doc : _ -> assertFailure $ "Expected an empty result, but got " <> show doc <> " for test case " - - -testRequestIdFederatedUserSearch :: HasCallStack => App () -testRequestIdFederatedUserSearch = do - let testCases = - [ - FedUserSearchTestCase "full_search" AllowAll AllowAll True True - ] - startDynamicBackends [def, def] $ \[d1, d2] -> do - void $ BrigI.createFedConn d2 (BrigI.FedConn d1 "full_search" Nothing) - void $ BrigI.createFedConn d1 (BrigI.FedConn d2 "full_search" Nothing) - forM_ testCases (federatedUserSearch d1 d2) diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index e10ae9bd453..4ec0f4f587c 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -88,6 +88,7 @@ import Data.UUID qualified as UUID import Data.UUID.V4 import Imports import Servant (FromHttpApiData (..), ToHttpApiData (..)) +import System.Logger (ToBytes) import Test.QuickCheck import Test.QuickCheck.Instances () @@ -413,7 +414,8 @@ newtype RequestId = RequestId ToByteString, Hashable, NFData, - Generic + Generic, + ToBytes ) instance ToSchema RequestId where diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 4570563dae7..a4105d54245 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -173,7 +173,7 @@ enqueueNotification ownDomain remoteDomain deliveryMode chanVar action = do . Log.field "error" (displayException e) . Log.field "willRetry" willRetry . Log.field "retryCount" status.rsIterNumber - . Log.field "requestId" (show rid) + . Log.field "request" rid go = do rid <- view Brig.requestId mChan <- timeout (1 :: Second) (readMVar chanVar) diff --git a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs index 1c0b8cc4d6a..f3268e1e366 100644 --- a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs +++ b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs @@ -52,7 +52,7 @@ enqueueSingleNotification remoteDomain deliveryMode chanVar action = do . Log.field "error" (displayException e) . Log.field "willRetry" willRetry . Log.field "retryCount" status.rsIterNumber - . Log.field "request" (show rid) + . Log.field "request" rid go ownDomain = do rid <- view reqId mChan <- timeout 1_000_000 (readMVar chanVar) From 5df6c47fabd57be2b421ae944615c432fec6c685 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 6 Dec 2023 15:53:01 +0000 Subject: [PATCH 04/20] clean up --- libs/wire-api-federation/src/Wire/API/Federation/Client.hs | 4 ++-- .../background-worker/src/Wire/BackendNotificationPusher.hs | 2 +- services/brig/src/Brig/Federation/Client.hs | 2 +- services/cargohold/src/CargoHold/Federation.hs | 2 +- services/federator/test/unit/Test/Federator/Client.hs | 6 +++--- services/galley/src/Galley/Intra/Federator.hs | 2 +- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 642093e7852..37ebd7f0dec 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -76,7 +76,7 @@ data FederatorClientEnv = FederatorClientEnv ceTargetDomain :: Domain, ceFederator :: Endpoint, ceHttp2Manager :: Http2Manager, - ceOriginRequestId :: RequestId + ceOriginRequestId :: Maybe RequestId } data FederatorClientVersionedEnv = FederatorClientVersionedEnv @@ -217,7 +217,7 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do toList (requestHeaders req) <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))] <> [(HTTP.hAccept, HTTP.renderHeader (toList $ req.requestAccept))] - <> [("Wire-Origin-Request-Id", toByteString' (ceOriginRequestId env))] + <> [("Wire-Origin-Request-Id", rid) | rid <- toByteString' <$> maybeToList (ceOriginRequestId env)] req' = HTTP2.requestBuilder (requestMethod req) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 67248a04ca0..5e139d06e0a 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -96,7 +96,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do ceHttp2Manager <- asks http2Manager let ceOriginDomain = notif.ownDomain ceTargetDomain = targetDomain - ceOriginRequestId = error "todo(leif): requestId not set" + ceOriginRequestId = notif.requestId fcEnv = FederatorClientEnv {..} liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body lift $ ack envelope diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index a4105d54245..c6829144d30 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -202,7 +202,7 @@ runBrigFederatorClient targetDomain action = do ceTargetDomain = targetDomain, ceFederator = endpoint, ceHttp2Manager = mgr, - ceOriginRequestId = rid + ceOriginRequestId = Just rid } liftIO (runFederatorClient env action) >>= either (throwE . FederationCallFailure) pure diff --git a/services/cargohold/src/CargoHold/Federation.hs b/services/cargohold/src/CargoHold/Federation.hs index 7ce7d4aae6b..25db77968ee 100644 --- a/services/cargohold/src/CargoHold/Federation.hs +++ b/services/cargohold/src/CargoHold/Federation.hs @@ -87,7 +87,7 @@ mkFederatorClientEnv remote = do ceTargetDomain = tDomain remote, ceFederator = endpoint, ceHttp2Manager = mgr, - ceOriginRequestId = rid + ceOriginRequestId = Just rid } executeFederated :: Remote x -> FederatorClient 'Cargohold a -> Handler a diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index f7eb01b209b..f3e51e8c4b1 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -101,7 +101,7 @@ withMockFederatorClient headers resp action = withTempMockFederator headers resp ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), ceHttp2Manager = mgr, - ceOriginRequestId = rid + ceOriginRequestId = Just rid } a <- runFederatorClient env action case a of @@ -143,7 +143,7 @@ testClientStreaming = withInfiniteMockServer $ \port -> do ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), ceHttp2Manager = mgr, - ceOriginRequestId = rid + ceOriginRequestId = Just rid } venv = FederatorClientVersionedEnv env Nothing let c = clientIn (Proxy @StreamingAPI) (Proxy @(FederatorClient 'Brig)) @@ -211,7 +211,7 @@ testClientConnectionError = do ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" 1, ceHttp2Manager = mgr, - ceOriginRequestId = rid + ceOriginRequestId = Just rid } result <- runFederatorClient env (fedClient @'Brig @"get-user-by-handle" handle) case result of diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index 6e09422c98a..df2e17100e2 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -69,7 +69,7 @@ runFederatedEither (tDomain -> remoteDomain) rpc = do ceTargetDomain = remoteDomain, ceFederator = fedEndpoint, ceHttp2Manager = mgr, - ceOriginRequestId = rid + ceOriginRequestId = Just rid } liftIO . fmap (first FederationCallFailure) $ runFederatorClient ce rpc From bc13bfc7231c513d411de3cfd1614e5877f034a4 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 6 Dec 2023 16:00:11 +0000 Subject: [PATCH 05/20] wip --- services/federator/src/Federator/ExternalServer.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index 9c47d0f3513..c30be68111c 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -29,6 +29,7 @@ import Data.Bifunctor import Data.ByteString qualified as BS import Data.ByteString.Builder import Data.ByteString.Lazy qualified as LBS +import Data.Default (Default (def)) import Data.Domain import Data.Id (RequestId) import Data.Metrics.Servant qualified as Metrics @@ -154,7 +155,7 @@ callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do . Log.field "originDomain" (domainText originDomain) . Log.field "component" (show component) . Log.field "rpc" rpc - . Log.field "requestId" (maybe "N/A" show mReqId) + . Log.field "request" (fromMaybe def mReqId) validatedDomain <- validateDomain cert originDomain @@ -165,7 +166,7 @@ callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do Log.debug $ Log.msg ("Inward Request response" :: ByteString) . Log.field "status" (show (responseStatusCode resp)) - . Log.field "requestId" (maybe "N/A" show mReqId) + . Log.field "request" (fromMaybe def mReqId) pure $ streamingResponseToWai resp From 10d2726cfafe154e3b1208a7244f77c534798e83 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 6 Dec 2023 16:01:42 +0000 Subject: [PATCH 06/20] changelog --- changelog.d/5-internal/WPB-4888 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/WPB-4888 diff --git a/changelog.d/5-internal/WPB-4888 b/changelog.d/5-internal/WPB-4888 new file mode 100644 index 00000000000..b704f96f217 --- /dev/null +++ b/changelog.d/5-internal/WPB-4888 @@ -0,0 +1 @@ +Request tracing across federated requests From 0250d348324241efbfa5ff39b2ab58cff6bd7a75 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 7 Dec 2023 14:26:04 +0000 Subject: [PATCH 07/20] clean up --- services/brig/brig.cabal | 1 - services/brig/default.nix | 1 - services/federator/federator.cabal | 1 - .../federator/test/unit/Test/Federator/Client.hs | 12 ++++-------- 4 files changed, 4 insertions(+), 11 deletions(-) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 57b0e8b7d56..951aa5eac85 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -519,7 +519,6 @@ executable brig-integration , unliftio , unordered-containers , uri-bytestring >=0.2 - , uuid , vector >=0.10 , wai , wai-extra diff --git a/services/brig/default.nix b/services/brig/default.nix index 14f1634b1d5..478d9975295 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -369,7 +369,6 @@ mkDerivation { unliftio unordered-containers uri-bytestring - uuid vector wai wai-extra diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index a451aa24bea..76f746e3a8c 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -413,7 +413,6 @@ test-suite federator-tests , transformers , types-common , unix - , uuid , wai , wai-extra , wai-utilities diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index f3e51e8c4b1..ae5df56c9f6 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -26,11 +26,10 @@ import Data.Bifunctor (first) import Data.ByteString qualified as BS import Data.ByteString.Builder (Builder, byteString, toLazyByteString) import Data.ByteString.Lazy qualified as LBS +import Data.Default (Default (def)) import Data.Domain -import Data.Id (RequestId (RequestId)) import Data.Proxy import Data.Text.Encoding qualified as Text -import Data.UUID.V1 (nextUUID) import Federator.MockServer import HTTP2.Client.Manager (defaultHttp2Manager, withHTTP2Request) import Imports @@ -94,14 +93,13 @@ withMockFederatorClient :: IO (Either ResponseFailure a, [FederatedRequest]) withMockFederatorClient headers resp action = withTempMockFederator headers resp $ \port -> do mgr <- defaultHttp2Manager - rid <- RequestId . cs . show . fromJust <$> liftIO nextUUID let env = FederatorClientEnv { ceOriginDomain = originDomain, ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), ceHttp2Manager = mgr, - ceOriginRequestId = Just rid + ceOriginRequestId = Just def } a <- runFederatorClient env action case a of @@ -136,14 +134,13 @@ type StreamingAPI = StreamGet NewlineFraming PlainText (SourceIO Text) testClientStreaming :: IO () testClientStreaming = withInfiniteMockServer $ \port -> do mgr <- defaultHttp2Manager - rid <- RequestId . cs . show . fromJust <$> liftIO nextUUID let env = FederatorClientEnv { ceOriginDomain = originDomain, ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), ceHttp2Manager = mgr, - ceOriginRequestId = Just rid + ceOriginRequestId = Just def } venv = FederatorClientVersionedEnv env Nothing let c = clientIn (Proxy @StreamingAPI) (Proxy @(FederatorClient 'Brig)) @@ -204,14 +201,13 @@ testClientConnectionError :: IO () testClientConnectionError = do handle <- generate arbitrary mgr <- defaultHttp2Manager - rid <- RequestId . cs . show . fromJust <$> liftIO nextUUID let env = FederatorClientEnv { ceOriginDomain = originDomain, ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" 1, ceHttp2Manager = mgr, - ceOriginRequestId = Just rid + ceOriginRequestId = Just def } result <- runFederatorClient env (fedClient @'Brig @"get-user-by-handle" handle) case result of From 78ba1749b7d8b62be42ef02fb462c08e776bf769 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 13 Dec 2023 16:06:34 +0000 Subject: [PATCH 08/20] removed default instance of request id --- integration/test/API/Brig.hs | 15 +++++++++++ integration/test/Test/Search.hs | 26 +++++++++++++++++++ integration/test/Testlib/ModService.hs | 2 +- libs/types-common/default.nix | 2 -- libs/types-common/src/Data/Id.hs | 5 ---- libs/types-common/types-common.cabal | 1 - .../src/Network/Wai/Utilities/Server.hs | 1 + .../API/Federation/BackendNotifications.hs | 8 +++--- .../src/Wire/API/Federation/Client.hs | 4 +-- .../API/Federation/HasNotificationEndpoint.hs | 2 +- .../Wire/BackendNotificationPusherSpec.hs | 5 ++-- services/brig/brig.cabal | 2 +- services/brig/default.nix | 2 +- services/brig/src/Brig/API/Handler.hs | 10 +++---- services/brig/src/Brig/App.hs | 3 +-- services/brig/src/Brig/Federation/Client.hs | 6 ++--- services/brig/src/Brig/Run.hs | 23 +++++++++++----- services/brig/src/Brig/User/API/Search.hs | 1 + services/cannon/cannon.cabal | 1 - services/cannon/default.nix | 2 -- services/cannon/src/Cannon/Types.hs | 5 ++-- services/cannon/src/Cannon/WS.hs | 3 +-- services/cargohold/cargohold.cabal | 1 - services/cargohold/default.nix | 2 -- services/cargohold/src/CargoHold/App.hs | 3 +-- .../cargohold/src/CargoHold/Federation.hs | 2 +- services/cargohold/src/CargoHold/Run.hs | 3 +-- services/federator/default.nix | 1 - services/federator/federator.cabal | 1 - .../federator/src/Federator/ExternalServer.hs | 15 +++++------ .../federator/src/Federator/InternalServer.hs | 4 +-- services/federator/src/Federator/Remote.hs | 6 ++--- services/federator/src/Federator/Run.hs | 4 +-- services/federator/src/Federator/Service.hs | 6 ++--- .../integration/Test/Federator/IngressSpec.hs | 3 ++- .../test/unit/Test/Federator/Client.hs | 8 +++--- .../unit/Test/Federator/ExternalServer.hs | 7 ++--- .../unit/Test/Federator/InternalServer.hs | 5 ++-- .../test/unit/Test/Federator/Remote.hs | 3 ++- services/galley/default.nix | 1 - services/galley/galley.cabal | 1 - services/galley/src/Galley/App.hs | 3 +-- .../Galley/Intra/BackendNotificationQueue.hs | 2 +- services/galley/src/Galley/Intra/Federator.hs | 2 +- services/galley/src/Galley/Run.hs | 3 +-- services/gundeck/default.nix | 2 -- services/gundeck/gundeck.cabal | 1 - services/gundeck/src/Gundeck/Env.hs | 3 +-- services/gundeck/src/Gundeck/Monad.hs | 3 +-- services/proxy/default.nix | 2 -- services/proxy/proxy.cabal | 1 - services/proxy/src/Proxy/Env.hs | 6 ++--- services/proxy/src/Proxy/Proxy.hs | 3 +-- services/spar/default.nix | 2 -- services/spar/spar.cabal | 1 - services/spar/src/Spar/Run.hs | 4 +-- tools/stern/default.nix | 2 -- tools/stern/src/Stern/App.hs | 5 ++-- tools/stern/stern.cabal | 1 - 59 files changed, 132 insertions(+), 119 deletions(-) diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 8e1c390862a..bdc3660a68f 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -206,6 +206,21 @@ searchContacts :: domain -> App Response searchContacts user searchTerm domain = do + req <- baseRequest user Brig Versioned "/search/contacts" + q <- asString searchTerm + d <- objDomain domain + submit "GET" (req & addQueryParams [("q", q), ("domain", d)] & addHeader "Request-Id" "1234567890") + +searchContacts' :: + ( MakesValue user, + MakesValue searchTerm, + MakesValue domain + ) => + user -> + searchTerm -> + domain -> + App Response +searchContacts' user searchTerm domain = do req <- baseRequest user Brig Versioned "/search/contacts" q <- asString searchTerm d <- objDomain domain diff --git a/integration/test/Test/Search.hs b/integration/test/Test/Search.hs index 955afd744f1..8540d372f9d 100644 --- a/integration/test/Test/Search.hs +++ b/integration/test/Test/Search.hs @@ -217,3 +217,29 @@ testFederatedUserSearchForNonTeamUser = do [] -> pure () doc : _ -> assertFailure $ "Expected an empty result, but got " <> show doc <> " for test case " + +testX2 :: HasCallStack => App () +testX2 = do + u1 <- randomUser OwnDomain def {BrigI.team = True} + u2 <- randomUser OtherDomain def {BrigI.team = True} + team2 <- u2 %. "team" + GalleyI.setTeamFeatureStatus OtherDomain team2 "searchVisibilityInbound" "enabled" + + u2Handle <- API.randomHandle + bindResponse (BrigP.putHandle u2 u2Handle) $ assertSuccess + BrigI.refreshIndex OtherDomain + + void $ BrigP.searchContacts u1 u2Handle OtherDomain >>= getJSON 200 + +testX1 :: HasCallStack => App () +testX1 = do + u1 <- randomUser OwnDomain def {BrigI.team = True} + u2 <- randomUser OtherDomain def {BrigI.team = True} + team2 <- u2 %. "team" + GalleyI.setTeamFeatureStatus OtherDomain team2 "searchVisibilityInbound" "enabled" + + u2Handle <- API.randomHandle + bindResponse (BrigP.putHandle u2 u2Handle) $ assertSuccess + BrigI.refreshIndex OtherDomain + + void $ BrigP.searchContacts' u1 u2Handle OtherDomain >>= getJSON 200 diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index e271bb3575d..c8a2dd9f23d 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -216,7 +216,7 @@ startDynamicBackend resource beOverrides = do setLogLevel = def { sparCfg = setField "saml.logLevel" ("Warn" :: String), - brigCfg = setField "logLevel" ("Warn" :: String), + brigCfg = setField "logLevel" ("Info" :: String), cannonCfg = setField "logLevel" ("Warn" :: String), cargoholdCfg = setField "logLevel" ("Warn" :: String), galleyCfg = setField "logLevel" ("Warn" :: String), diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix index b5dca28e57e..d13e256a89c 100644 --- a/libs/types-common/default.nix +++ b/libs/types-common/default.nix @@ -19,7 +19,6 @@ , cryptohash-sha1 , crypton , currency-codes -, data-default , generic-random , gitignoreSource , hashable @@ -75,7 +74,6 @@ mkDerivation { cryptohash-sha1 crypton currency-codes - data-default generic-random hashable http-api-data diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 4ec0f4f587c..c707a4ea02d 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -71,7 +71,6 @@ import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as L import Data.Char qualified as Char -import Data.Default (Default (..)) import Data.Hashable (Hashable) import Data.OpenApi qualified as S import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..)) @@ -423,10 +422,6 @@ instance ToSchema RequestId where RequestId . encodeUtf8 <$> (decodeUtf8 . unRequestId) .= text "RequestId" --- | Returns "N/A" -instance Default RequestId where - def = RequestId "N/A" - instance ToJSON RequestId where toJSON (RequestId r) = A.String (decodeUtf8 r) diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 070721fdc82..929980729e5 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -105,7 +105,6 @@ library , cryptohash-sha1 >=0.11.7.2 , crypton >=0.26 , currency-codes >=3.0.0.1 - , data-default >=0.5 , generic-random >=1.4.0.0 , hashable >=1.2 , http-api-data diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 1226a363137..e50247aa823 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -361,6 +361,7 @@ onError g m r k e = liftIO $ do when (code >= 500) $ either Prm.incCounter (counterIncr (path "net.errors")) `mapM_` m flushRequestBody r + Log.flush g k (jsonResponseToWai resp) -- | Log an 'Error' response for debugging purposes. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 7094ab798a5..9bcb9dbd083 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -33,7 +33,7 @@ data BackendNotification = BackendNotification -- pusher. This also makes development less clunky as we don't have to -- create a sum type here for all types of notifications that could exist. body :: RawJson, - requestId :: Maybe RequestId + requestId :: RequestId } deriving (Show, Eq) @@ -54,7 +54,7 @@ instance FromJSON BackendNotification where <*> o .: "targetComponent" <*> o .: "path" <*> (RawJson . TL.encodeUtf8 <$> o .: "body") - <*> o .:? "requestId" + <*> o .: "requestId" type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse @@ -74,7 +74,7 @@ sendNotification env component path body = runFederatorClient env . void $ clientIn (Proxy @BackendNotificationAPI) (Proxy @(FederatorClient c)) (withoutFirstSlash path) body -enqueue :: Q.Channel -> Maybe RequestId -> Domain -> Domain -> Q.DeliveryMode -> FedQueueClient c a -> IO a +enqueue :: Q.Channel -> RequestId -> Domain -> Domain -> Q.DeliveryMode -> FedQueueClient c a -> IO a enqueue channel requestId originDomain targetDomain deliveryMode (FedQueueClient action) = runReaderT action FedQueueEnv {..} @@ -132,7 +132,7 @@ data FedQueueEnv = FedQueueEnv originDomain :: Domain, targetDomain :: Domain, deliveryMode :: Q.DeliveryMode, - requestId :: Maybe RequestId + requestId :: RequestId } data EnqueueError = EnqueueError String diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 0f3a4ec92c1..390b06e8c9d 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -76,7 +76,7 @@ data FederatorClientEnv = FederatorClientEnv ceTargetDomain :: Domain, ceFederator :: Endpoint, ceHttp2Manager :: Http2Manager, - ceOriginRequestId :: Maybe RequestId + ceOriginRequestId :: RequestId } data FederatorClientVersionedEnv = FederatorClientVersionedEnv @@ -217,7 +217,7 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do toList (requestHeaders req) <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))] <> [(HTTP.hAccept, HTTP.renderHeader (toList $ req.requestAccept))] - <> [("Wire-Origin-Request-Id", rid) | rid <- toByteString' <$> maybeToList (ceOriginRequestId env)] + <> [("Wire-Origin-Request-Id", toByteString' $ ceOriginRequestId env)] req' = HTTP2.requestBuilder (requestMethod req) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index 9ff326186cf..ae841012a41 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -47,7 +47,7 @@ fedNotifToBackendNotif :: KnownSymbol (NotificationPath tag) => KnownComponent (NotificationComponent k) => ToJSON (Payload tag) => - Maybe RequestId -> + RequestId -> Domain -> Payload tag -> BackendNotification diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index ae926d37b74..3bb1cc5efb5 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -10,6 +10,7 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Builder qualified as Builder import Data.ByteString.Lazy qualified as LBS import Data.Domain +import Data.Id import Data.Range import Data.Sequence qualified as Seq import Data.Text qualified as Text @@ -63,7 +64,7 @@ spec = do ownDomain = origDomain, path = "/on-user-deleted-connections", body = RawJson $ Aeson.encode notifContent, - requestId = Nothing + requestId = RequestId "N/A" } envelope <- newMockEnvelope let msg = @@ -130,7 +131,7 @@ spec = do ownDomain = origDomain, path = "/on-user-deleted-connections", body = RawJson $ Aeson.encode notifContent, - requestId = Nothing + requestId = RequestId "N/A" } envelope <- newMockEnvelope let msg = diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 951aa5eac85..cfb2805172e 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -269,7 +269,6 @@ library , cql , cryptobox-haskell >=0.1.1 , currency-codes >=2.0 - , data-default >=0.5 , data-timeout >=0.3 , dns , dns-util @@ -519,6 +518,7 @@ executable brig-integration , unliftio , unordered-containers , uri-bytestring >=0.2 + , uuid , vector >=0.10 , wai , wai-extra diff --git a/services/brig/default.nix b/services/brig/default.nix index 478d9975295..dacf301274e 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -192,7 +192,6 @@ mkDerivation { cql cryptobox-haskell currency-codes - data-default data-timeout dns dns-util @@ -369,6 +368,7 @@ mkDerivation { unliftio unordered-containers uri-bytestring + uuid vector wai wai-extra diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index b066467982a..bbea923f517 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -42,13 +42,12 @@ import Brig.Options (setAllowlistEmailDomains, setAllowlistPhonePrefixes) import Brig.Phone (Phone, PhoneException (..)) import Control.Error import Control.Exception (throwIO) -import Control.Lens (set, view) +import Control.Lens (view) import Control.Monad.Catch (catches, throwM) import Control.Monad.Catch qualified as Catch import Control.Monad.Except (MonadError, throwError) import Data.Aeson (FromJSON) import Data.Aeson qualified as Aeson -import Data.Default (def) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.ZAuth.Validation qualified as ZV @@ -59,7 +58,7 @@ import Network.Wai.Predicate (Media) import Network.Wai.Routing (Continue) import Network.Wai.Utilities.Error ((!>>)) import Network.Wai.Utilities.Error qualified as WaiError -import Network.Wai.Utilities.Request (JsonRequest, lookupRequestId, parseBody) +import Network.Wai.Utilities.Request (JsonRequest, parseBody) import Network.Wai.Utilities.Response (addHeader, json, setStatus) import Network.Wai.Utilities.Server qualified as Server import Servant qualified @@ -80,11 +79,10 @@ runHandler :: Continue IO -> IO ResponseReceived runHandler e r h k = do - let e' = set requestId (maybe def RequestId (lookupRequestId r)) e a <- - runBrigToIO e' (runExceptT h) + runBrigToIO e (runExceptT h) `catches` brigErrorHandlers (view applog e) (unRequestId (view requestId e)) - either (onError (view applog e') r k) pure a + either (onError (view applog e) r k) pure a toServantHandler :: Env -> (Handler BrigCanonicalEffects) a -> Servant.Handler a toServantHandler env action = do diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 00f1d80f57b..6f0f9e85e2e 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -117,7 +117,6 @@ import Control.Lens hiding (index, (.=)) import Control.Monad.Catch import Control.Monad.Trans.Resource import Data.ByteString.Conversion -import Data.Default (def) import Data.Domain import Data.GeoIP2 qualified as GeoIp import Data.IP @@ -274,7 +273,7 @@ newEnv o = do _metrics = mtr, _applog = lgr, _internalEvents = eventsQueue, - _requestId = def, + _requestId = RequestId "N/A", _usrTemplates = utp, _provTemplates = ptp, _tmTemplates = ttp, diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index c6829144d30..447df159168 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -27,7 +27,7 @@ import Control.Retry import Control.Timeout import Data.Domain import Data.Handle -import Data.Id (ClientId, UserId) +import Data.Id import Data.Qualified import Data.Range (Range) import Data.Text qualified as T @@ -179,7 +179,7 @@ enqueueNotification ownDomain remoteDomain deliveryMode chanVar action = do mChan <- timeout (1 :: Second) (readMVar chanVar) case mChan of Nothing -> throwM NoRabbitMqChannel - Just chan -> liftIO $ enqueue chan (Just rid) ownDomain remoteDomain deliveryMode action + Just chan -> liftIO $ enqueue chan rid ownDomain remoteDomain deliveryMode action data NoRabbitMqChannel = NoRabbitMqChannel deriving (Show) @@ -202,7 +202,7 @@ runBrigFederatorClient targetDomain action = do ceTargetDomain = targetDomain, ceFederator = endpoint, ceHttp2Manager = mgr, - ceOriginRequestId = Just rid + ceOriginRequestId = rid } liftIO (runFederatorClient env action) >>= either (throwE . FederationCallFailure) pure diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 1992e2a2f51..0ec61c98026 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -46,12 +46,13 @@ import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch (MonadCatch, finally) import Control.Monad.Random (randomRIO) import Data.Aeson qualified as Aeson -import Data.Default (Default (def)) import Data.Id (RequestId (..)) import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) import Data.Text (unpack) +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Imports hiding (head) import Network.HTTP.Media qualified as HTTPMedia import Network.HTTP.Types qualified as HTTP @@ -66,7 +67,8 @@ import Network.Wai.Utilities.Server qualified as Server import Polysemy (Member) import Servant (Context ((:.)), (:<|>) (..)) import Servant qualified -import System.Logger (msg, val, (.=), (~~)) +import System.Logger (Logger, msg, val, (.=), (~~)) +import System.Logger qualified as Log import System.Logger.Class (MonadLogger, err) import Util.Options import Wire.API.Federation.API @@ -129,7 +131,9 @@ mkApp o = do . GZip.gunzip . GZip.gzip GZip.def . catchErrors (e ^. applog) [Right $ e ^. metrics] - . lookupRequestIdMiddleware + . lookupRequestIdMiddleware (e ^. applog) + + app :: Env -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived app e r k = runHandler e r (Server.route rtree r k) k -- the servant API wraps the one defined using wai-routing @@ -156,10 +160,15 @@ type ServantCombinedAPI = :<|> Servant.Raw ) -lookupRequestIdMiddleware :: (RequestId -> Wai.Application) -> Wai.Application -lookupRequestIdMiddleware mkapp req cont = do - let reqid = maybe def RequestId $ lookupRequestId req - mkapp reqid req cont +lookupRequestIdMiddleware :: Logger -> (RequestId -> Wai.Application) -> Wai.Application +lookupRequestIdMiddleware logger mkapp req cont = do + case lookupRequestId req of + Just rid -> do + mkapp (RequestId rid) req cont + Nothing -> do + localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + Log.info logger $ "request-id" .= localRid ~~ "request" .= (show req) ~~ msg (val "generated a new request id for local request") + mkapp localRid req cont customFormatters :: Servant.ErrorFormatters customFormatters = diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 44a87a7dd50..310d54b5861 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -72,6 +72,7 @@ search :: Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) search searcherId searchTerm maybeDomain maybeMaxResults = do + _ <- error "bäääääääm" -- FUTUREWORK(fisx): to reduce cassandra traffic, 'ensurePermissionsOrPersonalUser' could be -- run from `searchLocally` and `searchRemotely`, resp., where the team id is already -- available (at least in the local case) and can be passed as an argument rather than diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index 27429695a74..382fd4b8e04 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -85,7 +85,6 @@ library , bytestring >=0.10 , bytestring-conversion >=0.2 , conduit >=1.3.4.2 - , data-default >=0.5 , data-timeout >=0.3 , exceptions >=0.6 , extended diff --git a/services/cannon/default.nix b/services/cannon/default.nix index b1ff1ab1d2c..2161483f93f 100644 --- a/services/cannon/default.nix +++ b/services/cannon/default.nix @@ -12,7 +12,6 @@ , bytestring-conversion , conduit , criterion -, data-default , data-timeout , exceptions , extended @@ -66,7 +65,6 @@ mkDerivation { bytestring bytestring-conversion conduit - data-default data-timeout exceptions extended diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index e6937cd1e94..01f5b2a64a9 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -47,7 +47,6 @@ import Cannon.WS qualified as WS import Control.Concurrent.Async (mapConcurrently) import Control.Lens import Control.Monad.Catch -import Data.Default (def) import Data.Metrics.Middleware import Data.Text.Encoding import Imports @@ -108,7 +107,7 @@ mkEnv :: Clock -> Env mkEnv m external o l d p g t = - Env m o l d def $ + Env m o l d (RequestId "N/A") $ WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) runCannon :: Env -> Cannon a -> Request -> IO a @@ -120,7 +119,7 @@ runCannon' :: Env -> Cannon a -> IO a runCannon' e c = runReaderT (unCannon c) e lookupReqId :: Request -> RequestId -lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders +lookupReqId = RequestId . fromMaybe "N/A" . lookup requestIdName . requestHeaders {-# INLINE lookupReqId #-} options :: Cannon Opts diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index d6c1277dcd5..1cc3b3aaa84 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -61,7 +61,6 @@ import Data.Aeson hiding (Error, Key) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as L -import Data.Default (def) import Data.Hashable import Data.Id (ClientId, ConnId (..), UserId) import Data.List.Extra (chunksOf) @@ -193,7 +192,7 @@ env :: Clock -> DrainOpts -> Env -env leh lp gh gp = Env leh lp (host gh . port gp $ empty) def +env leh lp gh gp = Env leh lp (host gh . port gp $ empty) (RequestId "N/A") runWS :: MonadIO m => Env -> WS a -> m a runWS e m = liftIO $ runReaderT (_conn m) e diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index f7ae9eb5bbe..02a626b018e 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -101,7 +101,6 @@ library , conduit-extra >=1.1.5 , containers , crypton >=0.20 - , data-default >=0.5 , errors >=1.4 , exceptions >=0.6 , extended diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 5dbc7d1a5b4..e624388b3b1 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -19,7 +19,6 @@ , conduit-extra , containers , crypton -, data-default , errors , exceptions , extended @@ -94,7 +93,6 @@ mkDerivation { conduit-extra containers crypton - data-default errors exceptions extended diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index b51edbc6228..36af17c0051 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -61,7 +61,6 @@ import Control.Exception (throw) import Control.Lens (Lens', makeLenses, non, view, (?~), (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Resource (ResourceT, runResourceT, transResourceT) -import Data.Default (def) import qualified Data.Map as Map import Data.Metrics.Middleware (Metrics) import qualified Data.Metrics.Middleware as Metrics @@ -110,7 +109,7 @@ newEnv opts = do awsEnv <- initAws (opts ^. Opt.aws) logger httpMgr multiIngressAWS <- initMultiIngressAWS logger httpMgr let localDomain = toLocalUnsafe (opts ^. Opt.settings . Opt.federationDomain) () - pure $ Env awsEnv metricsStorage logger httpMgr http2Mgr def opts localDomain multiIngressAWS + pure $ Env awsEnv metricsStorage logger httpMgr http2Mgr (RequestId "N/A") opts localDomain multiIngressAWS where initMultiIngressAWS :: Logger -> Manager -> IO (Map String AWS.Env) initMultiIngressAWS logger httpMgr = diff --git a/services/cargohold/src/CargoHold/Federation.hs b/services/cargohold/src/CargoHold/Federation.hs index 25db77968ee..7ce7d4aae6b 100644 --- a/services/cargohold/src/CargoHold/Federation.hs +++ b/services/cargohold/src/CargoHold/Federation.hs @@ -87,7 +87,7 @@ mkFederatorClientEnv remote = do ceTargetDomain = tDomain remote, ceFederator = endpoint, ceHttp2Manager = mgr, - ceOriginRequestId = Just rid + ceOriginRequestId = rid } executeFederated :: Remote x -> FederatorClient 'Cargohold a -> Handler a diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index 4077976ff5f..74e3bac7b8c 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -32,7 +32,6 @@ import CargoHold.Options hiding (aws) import Control.Exception (bracket) import Control.Lens (set, (^.)) import Control.Monad.Codensity -import Data.Default import Data.Id import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) @@ -84,7 +83,7 @@ mkApp o = Codensity $ \k -> . catchErrors (e ^. appLogger) [Right $ e ^. metrics] servantApp :: Env -> Application servantApp e0 r = do - let e = set requestId (maybe def RequestId (lookupRequestId r)) e0 + let e = set requestId (RequestId $ fromMaybe "N/A" (lookupRequestId r)) e0 Servant.serveWithContext (Proxy @CombinedAPI) ((o ^. settings . federationDomain) :. Servant.EmptyContext) diff --git a/services/federator/default.nix b/services/federator/default.nix index 8f8915e4a16..53f1495de50 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -88,7 +88,6 @@ mkDerivation { containers crypton-x509 crypton-x509-validation - data-default dns dns-util exceptions diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 76f746e3a8c..253bf26acfc 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -115,7 +115,6 @@ library , containers , crypton-x509 , crypton-x509-validation - , data-default , dns , dns-util , exceptions diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index c30be68111c..caac3b498a6 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -29,9 +29,8 @@ import Data.Bifunctor import Data.ByteString qualified as BS import Data.ByteString.Builder import Data.ByteString.Lazy qualified as LBS -import Data.Default (Default (def)) import Data.Domain -import Data.Id (RequestId) +import Data.Id (RequestId (..)) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) import Data.Sequence qualified as Seq @@ -118,7 +117,7 @@ server mgr intPort interpreter = API { status = Health.status mgr "internal server" intPort, externalRequest = \component rpc mReqId remoteDomain remoteCert -> - Tagged $ \req respond -> runCodensity (interpreter (callInward component rpc mReqId remoteDomain remoteCert req)) respond + Tagged $ \req respond -> runCodensity (interpreter (callInward component rpc (fromMaybe (RequestId "N/A") mReqId) remoteDomain remoteCert req)) respond } -- FUTUREWORK(federation): Versioning of the federation API. @@ -135,12 +134,12 @@ callInward :: ) => Component -> RPC -> - Maybe RequestId -> + RequestId -> Domain -> CertHeader -> Wai.Request -> Sem r Wai.Response -callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do +callInward component (RPC rpc) rid originDomain (CertHeader cert) wreq = do incomingCounterIncr originDomain -- only POST is supported when (Wai.requestMethod wreq /= HTTP.methodPost) $ @@ -155,18 +154,18 @@ callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do . Log.field "originDomain" (domainText originDomain) . Log.field "component" (show component) . Log.field "rpc" rpc - . Log.field "request" (fromMaybe def mReqId) + . Log.field "request" rid validatedDomain <- validateDomain cert originDomain let path = LBS.toStrict (toLazyByteString (HTTP.encodePathSegments ["federation", rpc])) body <- embed $ Wai.lazyRequestBody wreq - resp <- serviceCall component path body mReqId validatedDomain + resp <- serviceCall component path body rid validatedDomain Log.debug $ Log.msg ("Inward Request response" :: ByteString) . Log.field "status" (show (responseStatusCode resp)) - . Log.field "request" (fromMaybe def mReqId) + . Log.field "request" rid pure $ streamingResponseToWai resp diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index 6c8ea979a5e..7de3ef3843c 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -92,7 +92,7 @@ server mgr extPort interpreter = API { status = Health.status mgr "external server" extPort, internalRequest = \mReqId remoteDomain component rpc -> - Tagged $ \req respond -> runCodensity (interpreter (callOutward mReqId remoteDomain component rpc req)) respond + Tagged $ \req respond -> runCodensity (interpreter (callOutward (fromMaybe (RequestId "N/A") mReqId) remoteDomain component rpc req)) respond } callOutward :: @@ -104,7 +104,7 @@ callOutward :: Member Metrics r, Member (Logger (Log.Msg -> Log.Msg)) r ) => - Maybe RequestId -> + RequestId -> Domain -> Component -> RPC -> diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 53e1d35b378..d9efd143506 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -70,7 +70,7 @@ instance AsWai RemoteError where data Remote m a where DiscoverAndCall :: - Maybe RequestId -> + RequestId -> Domain -> Component -> Text -> @@ -90,7 +90,7 @@ interpretRemote :: Sem (Remote ': r) a -> Sem r a interpretRemote = interpret $ \case - DiscoverAndCall mReqId domain component rpc headers body -> do + DiscoverAndCall rid domain component rpc headers body -> do target@(SrvTarget hostname port) <- discoverFederatorWithError domain let path = LBS.toStrict . toLazyByteString $ @@ -99,7 +99,7 @@ interpretRemote = interpret $ \case -- filter out Host header, because the HTTP2 client adds it back headers' = filter ((/= "Host") . fst) headers - <> [(RPC.requestIdName, rid) | RequestId rid <- maybeToList mReqId] + <> [(RPC.requestIdName, unRequestId rid)] req' = HTTP2.requestBuilder HTTP.methodPost path headers' body mgr <- input diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index ebdf4cb295e..3ebcb41fbf1 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -37,7 +37,7 @@ where import Control.Concurrent.Async import Control.Exception (bracket) import Control.Lens ((^.)) -import Data.Default (def) +import Data.Id import Data.Metrics.Middleware qualified as Metrics import Federator.Env import Federator.ExternalServer (serveInward) @@ -92,7 +92,7 @@ run opts = do newEnv :: Opts -> DNS.Resolver -> Log.Logger -> IO Env newEnv o _dnsResolver _applog = do _metrics <- Metrics.metrics - let _requestId = def + let _requestId = RequestId "N/A" _runSettings = Opt.optSettings o _service Brig = Opt.brig o _service Galley = Opt.galley o diff --git a/services/federator/src/Federator/Service.hs b/services/federator/src/Federator/Service.hs index d22d91929c8..f61075f2e41 100644 --- a/services/federator/src/Federator/Service.hs +++ b/services/federator/src/Federator/Service.hs @@ -52,7 +52,7 @@ type ServiceStreaming = Service (SourceT IO ByteString) data Service body m a where -- | Returns status, headers and body, 'HTTP.Response' is not nice to work with in tests - ServiceCall :: Component -> ByteString -> LByteString -> Maybe RequestId -> Domain -> Service body m (Servant.ResponseF body) + ServiceCall :: Component -> ByteString -> LByteString -> RequestId -> Domain -> Service body m (Servant.ResponseF body) makeSem ''Service @@ -81,7 +81,7 @@ interpretServiceHTTP :: Sem (ServiceStreaming ': r) a -> Sem r a interpretServiceHTTP = interpret $ \case - ServiceCall component rpcPath body mReqId domain -> do + ServiceCall component rpcPath body rid domain -> do Endpoint serviceHost servicePort <- inputs (view service) <*> pure component manager <- inputs (view httpManager) let req = @@ -95,7 +95,7 @@ interpretServiceHTTP = interpret $ \case [ ("Content-Type", "application/json"), (originDomainHeaderName, cs (domainText domain)) ] - <> [(RPC.requestIdName, rid) | RequestId rid <- maybeToList mReqId] + <> [(RPC.requestIdName, unRequestId rid)] } embed $ diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 84d08fbd354..38c75dbfb68 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -23,6 +23,7 @@ import Control.Monad.Codensity import Data.Aeson qualified as Aeson import Data.Binary.Builder import Data.Domain +import Data.Id import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent)) import Data.Text.Encoding qualified as Text import Federator.Discovery @@ -151,4 +152,4 @@ inwardBrigCallViaIngressWithSettings sslCtx requestPath payload = . assertNoError @DiscoveryFailure . discoverConst target . interpretRemote - $ discoverAndCall Nothing (Domain "example.com") Brig requestPath headers payload + $ discoverAndCall (RequestId "N/A") (Domain "example.com") Brig requestPath headers payload diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index ae5df56c9f6..2b79f8ab2a1 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -26,8 +26,8 @@ import Data.Bifunctor (first) import Data.ByteString qualified as BS import Data.ByteString.Builder (Builder, byteString, toLazyByteString) import Data.ByteString.Lazy qualified as LBS -import Data.Default (Default (def)) import Data.Domain +import Data.Id import Data.Proxy import Data.Text.Encoding qualified as Text import Federator.MockServer @@ -99,7 +99,7 @@ withMockFederatorClient headers resp action = withTempMockFederator headers resp ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), ceHttp2Manager = mgr, - ceOriginRequestId = Just def + ceOriginRequestId = RequestId "N/A" } a <- runFederatorClient env action case a of @@ -140,7 +140,7 @@ testClientStreaming = withInfiniteMockServer $ \port -> do ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" (fromIntegral port), ceHttp2Manager = mgr, - ceOriginRequestId = Just def + ceOriginRequestId = RequestId "N/A" } venv = FederatorClientVersionedEnv env Nothing let c = clientIn (Proxy @StreamingAPI) (Proxy @(FederatorClient 'Brig)) @@ -207,7 +207,7 @@ testClientConnectionError = do ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" 1, ceHttp2Manager = mgr, - ceOriginRequestId = Just def + ceOriginRequestId = RequestId "N/A" } result <- runFederatorClient env (fedClient @'Brig @"get-user-by-handle" handle) case result of diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index 2cfe4a49307..c65ccc4428f 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -23,6 +23,7 @@ import Control.Monad.Codensity import Data.ByteString qualified as BS import Data.Default import Data.Domain +import Data.Id import Data.Text.Encoding qualified as Text import Federator.Discovery import Federator.Error.ServerError (ServerError (..)) @@ -137,7 +138,7 @@ requestBrigSuccess = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") (RequestId "N/A") aValidDomain (CertHeader cert) request let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls Wai.responseStatus res @?= HTTP.status200 @@ -165,7 +166,7 @@ requestBrigFailure = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") (RequestId "N/A") aValidDomain (CertHeader cert) request let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls @@ -195,7 +196,7 @@ requestGalleySuccess = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Galley (RPC "get-conversations") Nothing aValidDomain (CertHeader cert) request + $ callInward Galley (RPC "get-conversations") (RequestId "N/A") aValidDomain (CertHeader cert) request let expectedCall = Call Galley "/federation/get-conversations" "\"foo\"" aValidDomain embed $ assertEqual "one call to galley should be made" [expectedCall] actualCalls embed $ Wai.responseStatus res @?= HTTP.status200 diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 3fb41d2d869..5756c86be3e 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -23,6 +23,7 @@ import Data.ByteString.Builder import Data.ByteString.Conversion import Data.Default import Data.Domain +import Data.Id import Federator.Error.ServerError import Federator.InternalServer (callOutward) import Federator.Metrics @@ -102,7 +103,7 @@ federatedRequestSuccess = . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "target.example.com") FullSearch FederationRestrictionAllowAll] 10) . assertMetrics - $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward (RequestId "N/A") targetDomain Brig (RPC "get-user-by-handle") request Wai.responseStatus res @?= HTTP.status200 body <- Wai.lazyResponseBody res body @?= "\"bar\"" @@ -148,7 +149,7 @@ federatedRequestFailureAllowList = . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "hello.world") FullSearch FederationRestrictionAllowAll] 10) . interpretMetricsEmpty - $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward (RequestId "N/A") targetDomain Brig (RPC "get-user-by-handle") request eith @?= Left (FederationDenied targetDomain) -- @END diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 7d7ec063733..43be50b23d1 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -20,6 +20,7 @@ module Test.Federator.Remote where import Control.Exception (bracket) import Control.Monad.Codensity import Data.Domain +import Data.Id import Federator.Discovery import Federator.Env (mkHttp2Manager) import Federator.Options @@ -89,7 +90,7 @@ mkTestCall sslCtx hostname port = do . discoverLocalhost hostname port . assertNoError @DiscoveryFailure . interpretRemote - $ discoverAndCall Nothing (Domain "localhost") Brig "test" [] mempty + $ discoverAndCall (RequestId "N/A") (Domain "localhost") Brig "test" [] mempty withMockServer :: Warp.TLSSettings -> (Warp.Port -> IO a) -> IO a withMockServer tls k = diff --git a/services/galley/default.nix b/services/galley/default.nix index c1f30339bba..12b1d54aa86 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -153,7 +153,6 @@ mkDerivation { crypton crypton-x509 currency-codes - data-default data-timeout either enclosed-exceptions diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 016ebba4fa0..439ba32f18c 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -305,7 +305,6 @@ library , crypton , crypton-x509 , currency-codes >=2.0 - , data-default >=0.5 , data-timeout , either , enclosed-exceptions >=1.0 diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index e5054881468..8eded007344 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -50,7 +50,6 @@ import Cassandra qualified as C import Cassandra.Settings qualified as C import Control.Error hiding (err) import Control.Lens hiding ((.=)) -import Data.Default (def) import Data.List.NonEmpty qualified as NE import Data.Metrics.Middleware import Data.Misc @@ -165,7 +164,7 @@ createEnv m o l = do mgr <- initHttpManager o h2mgr <- initHttp2Manager codeURIcfg <- validateOptions o - Env def m o l mgr h2mgr (o ^. O.federator) (o ^. O.brig) cass + Env (RequestId "N/A") m o l mgr h2mgr (o ^. O.federator) (o ^. O.brig) cass <$> Q.new 16000 <*> initExtEnv <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. journal) diff --git a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs index f3268e1e366..316a94dcce7 100644 --- a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs +++ b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs @@ -59,7 +59,7 @@ enqueueSingleNotification remoteDomain deliveryMode chanVar action = do case mChan of Nothing -> throwM NoRabbitMqChannel Just chan -> do - liftIO $ enqueue chan (Just rid) ownDomain remoteDomain deliveryMode action + liftIO $ enqueue chan rid ownDomain remoteDomain deliveryMode action enqueueNotification :: Domain -> Q.DeliveryMode -> FedQueueClient c a -> ExceptT FederationError App a enqueueNotification remoteDomain deliveryMode action = do diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index df2e17100e2..6e09422c98a 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -69,7 +69,7 @@ runFederatedEither (tDomain -> remoteDomain) rpc = do ceTargetDomain = remoteDomain, ceFederator = fedEndpoint, ceHttp2Manager = mgr, - ceOriginRequestId = Just rid + ceOriginRequestId = rid } liftIO . fmap (first FederationCallFailure) $ runFederatorClient ce rpc diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 0fd7e80b1e3..d9471a490a3 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -32,7 +32,6 @@ import Control.Exception (finally) import Control.Lens (view, (.~), (^.)) import Control.Monad.Codensity import Data.Aeson qualified as Aeson -import Data.Default import Data.Id import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) @@ -123,7 +122,7 @@ mkApp opts = r lookupReqId :: Request -> RequestId - lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders + lookupReqId = maybe (RequestId "N/A") RequestId . lookup requestIdName . requestHeaders closeApp :: Env -> IO () closeApp env = do diff --git a/services/gundeck/default.nix b/services/gundeck/default.nix index ec399622ecf..3dad13b4224 100644 --- a/services/gundeck/default.nix +++ b/services/gundeck/default.nix @@ -20,7 +20,6 @@ , cassandra-util , containers , criterion -, data-default , errors , exceptions , extended @@ -102,7 +101,6 @@ mkDerivation { bytestring-conversion cassandra-util containers - data-default errors exceptions extended diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index b90bc99c681..05d36ff0217 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -124,7 +124,6 @@ library , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 , containers >=0.5 - , data-default >=0.5 , errors >=2.0 , exceptions >=0.4 , extended diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index f6e205e74e5..df8850991d6 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -27,7 +27,6 @@ import Control.AutoUpdate import Control.Concurrent.Async (Async) import Control.Lens (makeLenses, (^.)) import Control.Retry (capDelay, exponentialBackoff) -import Data.Default (def) import Data.List.NonEmpty qualified as NE import Data.Metrics.Middleware (Metrics) import Data.Misc (Milliseconds (..)) @@ -112,7 +111,7 @@ createEnv m o = do { updateAction = Ms . round . (* 1000) <$> getPOSIXTime } mtbs <- mkThreadBudgetState `mapM` (o ^. settings . maxConcurrentNativePushes) - pure $! (rThread : rAdditionalThreads,) $! Env def m o l n p r rAdditional a io mtbs + pure $! (rThread : rAdditionalThreads,) $! Env (RequestId "N/A") m o l n p r rAdditional a io mtbs reqIdMsg :: RequestId -> Logger.Msg -> Logger.Msg reqIdMsg = ("request" Logger..=) . unRequestId diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 7995b71b17f..6f9b14bed4a 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -51,7 +51,6 @@ import Control.Exception (throwIO) import Control.Lens import Control.Monad.Catch hiding (tryJust) import Data.Aeson (FromJSON) -import Data.Default (def) import Data.Misc (Milliseconds (..)) import Database.Redis qualified as Redis import Gundeck.Env @@ -182,7 +181,7 @@ runDirect e m = ) lookupReqId :: Request -> RequestId -lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders +lookupReqId = RequestId . fromMaybe "N/A" . lookup requestIdName . requestHeaders {-# INLINE lookupReqId #-} fromJsonBody :: FromJSON a => JsonRequest a -> Gundeck a diff --git a/services/proxy/default.nix b/services/proxy/default.nix index e3301202ba8..ee08f5dd212 100644 --- a/services/proxy/default.nix +++ b/services/proxy/default.nix @@ -9,7 +9,6 @@ , bytestring , case-insensitive , configurator -, data-default , exceptions , extended , gitignoreSource @@ -45,7 +44,6 @@ mkDerivation { bytestring case-insensitive configurator - data-default exceptions extended http-client diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index 3cf6c0ec13f..7a5cee12e01 100644 --- a/services/proxy/proxy.cabal +++ b/services/proxy/proxy.cabal @@ -80,7 +80,6 @@ library , bytestring >=0.10 , case-insensitive >=1.2 , configurator >=0.3 - , data-default >=0.5 , exceptions >=0.8 , extended , http-client >=0.7 diff --git a/services/proxy/src/Proxy/Env.hs b/services/proxy/src/Proxy/Env.hs index b455e27b0d8..d8850dab273 100644 --- a/services/proxy/src/Proxy/Env.hs +++ b/services/proxy/src/Proxy/Env.hs @@ -33,8 +33,7 @@ where import Control.Lens (makeLenses, (^.)) import Data.Configurator import Data.Configurator.Types -import Data.Default (def) -import Data.Id (RequestId) +import Data.Id (RequestId (..)) import Data.Metrics.Middleware (Metrics) import Imports import Network.HTTP.Client @@ -66,7 +65,8 @@ createEnv m o = do } let ac = AutoConfig 60 (reloadError g) (c, t) <- autoReload ac [Required $ o ^. secretsConfig] - pure $! Env def m o g n c t + let rid = RequestId "N/A" + pure $! Env rid m o g n c t where reloadError g x = Logger.err g (Logger.msg $ Logger.val "Failed reloading config: " Logger.+++ show x) diff --git a/services/proxy/src/Proxy/Proxy.hs b/services/proxy/src/Proxy/Proxy.hs index 396ed3ac839..a50ae884c63 100644 --- a/services/proxy/src/Proxy/Proxy.hs +++ b/services/proxy/src/Proxy/Proxy.hs @@ -27,7 +27,6 @@ import Bilge.Request (requestIdName) import Control.Lens hiding ((.=)) import Control.Monad.Catch import Control.Monad.IO.Unlift () -import Data.Default (def) import Data.Id (RequestId (..)) import Imports import Network.Wai @@ -61,4 +60,4 @@ reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} lookupReqId :: Request -> RequestId -lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders +lookupReqId = RequestId . fromMaybe "N/A" . lookup requestIdName . requestHeaders diff --git a/services/spar/default.nix b/services/spar/default.nix index afd5513a261..daebe1a84f6 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -20,7 +20,6 @@ , cookie , crypton , crypton-x509 -, data-default , email-validate , exceptions , extended @@ -100,7 +99,6 @@ mkDerivation { cookie crypton crypton-x509 - data-default exceptions extended galley-types diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 4f4dfdaf319..cf474bfe099 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -160,7 +160,6 @@ library , cookie , crypton , crypton-x509 - , data-default , exceptions , extended , galley-types diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 5331fddabc9..fd747408ba3 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -33,7 +33,7 @@ import Cassandra as Cas import qualified Cassandra.Schema as Cas import qualified Cassandra.Settings as Cas import Control.Lens -import Data.Default (def) +import Data.Id import Data.List.NonEmpty as NE import Data.Metrics.Servant (servantPrometheusMiddleware) import Data.Proxy (Proxy (Proxy)) @@ -135,5 +135,5 @@ mkApp sparCtxOpts = do lookupRequestIdMiddleware :: (Bilge.RequestId -> Application) -> Application lookupRequestIdMiddleware mkapp req cont = do - let reqid = maybe def Bilge.RequestId $ lookupRequestId req + let reqid = RequestId . fromMaybe "N/A" $ lookupRequestId req mkapp reqid req cont diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 2c5867d329a..4359d6841b3 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -11,7 +11,6 @@ , bytestring-conversion , containers , cookie -, data-default , errors , exceptions , extended @@ -68,7 +67,6 @@ mkDerivation { bytestring bytestring-conversion containers - data-default errors exceptions extended diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index 1e4a1f2bfde..e5b74b1b11d 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -32,8 +32,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.Trans.Class import Data.ByteString.Conversion (toByteString') -import Data.Default (def) -import Data.Id (UserId) +import Data.Id import Data.Metrics.Middleware qualified as Metrics import Data.Text.Encoding (encodeUtf8) import Data.UUID (toString) @@ -71,7 +70,7 @@ newEnv :: Opts -> IO Env newEnv o = do mt <- Metrics.metrics l <- Log.mkLogger (O.logLevel o) (O.logNetStrings o) (O.logFormat o) - Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l mt def + Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l mt (RequestId "N/A") <$> newManager where mkRequest s = Bilge.host (encodeUtf8 (s ^. host)) . Bilge.port (s ^. port) $ Bilge.empty diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 2b293afa246..30e0bc8256f 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -80,7 +80,6 @@ library , bytestring >=0.10 , bytestring-conversion >=0.2 , containers - , data-default >=0.5 , errors >=1.4 , exceptions >=0.6 , extended From daeebb023ad5aae0e697713c6fa56b3fb28c8fb2 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 13 Dec 2023 16:18:04 +0000 Subject: [PATCH 09/20] req id in galley --- services/galley/src/Galley/Run.hs | 44 ++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 16 deletions(-) diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index d9471a490a3..252f7800cba 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -40,6 +40,8 @@ import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware) import Data.Misc (portNumber) import Data.Singletons import Data.Text (unpack) +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Galley.API qualified as API import Galley.API.Federation import Galley.API.Internal @@ -58,6 +60,7 @@ import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip import Network.Wai.Utilities.Server import Servant hiding (route) +import System.Logger (Logger, msg, val, (.=), (~~)) import System.Logger qualified as Log import System.Logger.Extended (mkLogger) import Util.Options @@ -105,24 +108,33 @@ mkApp opts = where rtree = compile API.waiSitemap runGalley e r k = evalGalleyToIO e (route rtree r k) + -- the servant API wraps the one defined using wai-routing - servantApp e0 r = - let e = reqId .~ lookupReqId r $ e0 - in Servant.serveWithContext - (Proxy @CombinedAPI) - ( view (options . settings . federationDomain) e - :. customFormatters - :. Servant.EmptyContext - ) - ( hoistAPIHandler (toServantHandler e) API.servantSitemap - :<|> hoistAPIHandler (toServantHandler e) internalAPI - :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap - :<|> Servant.Tagged (runGalley e) - ) - r + servantApp :: Env -> Application + servantApp e0 r cont = do + rid <- lookupReqId (e0 ^. applog) r + let e = reqId .~ rid $ e0 + Servant.serveWithContext + (Proxy @CombinedAPI) + ( view (options . settings . federationDomain) e + :. customFormatters + :. Servant.EmptyContext + ) + ( hoistAPIHandler (toServantHandler e) API.servantSitemap + :<|> hoistAPIHandler (toServantHandler e) internalAPI + :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap + :<|> Servant.Tagged (runGalley e) + ) + r + cont - lookupReqId :: Request -> RequestId - lookupReqId = maybe (RequestId "N/A") RequestId . lookup requestIdName . requestHeaders + lookupReqId :: Logger -> Request -> IO RequestId + lookupReqId l r = case lookup requestIdName $ requestHeaders r of + Just rid -> pure $ RequestId rid + Nothing -> do + localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + Log.info l $ "request-id" .= localRid ~~ "request" .= (show r) ~~ msg (val "generated a new request id for local request") + pure localRid closeApp :: Env -> IO () closeApp env = do From 5cf56e0b0490685a688508837c9572d67ef3ecac Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 13 Dec 2023 16:25:58 +0000 Subject: [PATCH 10/20] gen req id for local cargohold requests --- services/cargohold/src/CargoHold/Run.hs | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index 74e3bac7b8c..cb26ea8c349 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -24,13 +24,14 @@ where import AWS.Util (readAuthExpiration) import qualified Amazonka as AWS +import Bilge.Request (requestIdName) import CargoHold.API.Federation import CargoHold.API.Public import CargoHold.AWS (amazonkaEnv) import CargoHold.App hiding (settings) import CargoHold.Options hiding (aws) import Control.Exception (bracket) -import Control.Lens (set, (^.)) +import Control.Lens ((.~), (^.)) import Control.Monad.Codensity import Data.Id import Data.Metrics (Metrics) @@ -38,15 +39,18 @@ import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant import Data.Proxy import Data.Text (unpack) +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Imports import qualified Network.Wai as Wai import qualified Network.Wai.Middleware.Gzip as GZip -import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as Server import qualified Servant import Servant.API import Servant.Server hiding (Handler, runHandler) +import System.Logger (Logger, msg, val, (.=), (~~)) +import qualified System.Logger as Log import qualified UnliftIO.Async as Async import Util.Options import Wire.API.Routes.API @@ -82,8 +86,9 @@ mkApp o = Codensity $ \k -> . GZip.gzip GZip.def . catchErrors (e ^. appLogger) [Right $ e ^. metrics] servantApp :: Env -> Application - servantApp e0 r = do - let e = set requestId (RequestId $ fromMaybe "N/A" (lookupRequestId r)) e0 + servantApp e0 r cont = do + rid <- lookupReqId (e0 ^. appLogger) r + let e = requestId .~ rid $ e0 Servant.serveWithContext (Proxy @CombinedAPI) ((o ^. settings . federationDomain) :. Servant.EmptyContext) @@ -92,6 +97,15 @@ mkApp o = Codensity $ \k -> :<|> hoistServerWithDomain @InternalAPI (toServantHandler e) internalSitemap ) r + cont + + lookupReqId :: Logger -> Wai.Request -> IO RequestId + lookupReqId l r = case lookup requestIdName $ Wai.requestHeaders r of + Just rid -> pure $ RequestId rid + Nothing -> do + localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + Log.info l $ "request-id" .= localRid ~~ "request" .= (show r) ~~ msg (val "generated a new request id for local request") + pure localRid toServantHandler :: Env -> Handler a -> Servant.Handler a toServantHandler env = liftIO . runHandler env From c1f1eaf0db97bc325806cc7f6c1a328a7e222d0c Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 13 Dec 2023 16:32:25 +0000 Subject: [PATCH 11/20] gen req id for local reqs in spar --- services/spar/src/Spar/Run.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index fd747408ba3..460e13f9612 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -32,11 +32,13 @@ import qualified Bilge import Cassandra as Cas import qualified Cassandra.Schema as Cas import qualified Cassandra.Settings as Cas -import Control.Lens +import Control.Lens (to, (^.)) import Data.Id import Data.List.NonEmpty as NE import Data.Metrics.Servant (servantPrometheusMiddleware) import Data.Proxy (Proxy (Proxy)) +import qualified Data.UUID as UUID +import Data.UUID.V4 as UUID import Imports import Network.Wai (Application) import qualified Network.Wai as Wai @@ -50,7 +52,8 @@ import qualified Spar.Data as Data import Spar.Data.Instances () import Spar.Options import Spar.Orphans () -import System.Logger.Class (Logger) +import System.Logger (Logger, msg, val, (.=), (~~)) +import qualified System.Logger as Log import qualified System.Logger.Extended as Log import Util.Options (endpoint, filterNodesByDatacentre, host, keyspace, port) import Wire.API.Routes.Version.Wai @@ -124,7 +127,7 @@ mkApp sparCtxOpts = do -- still here for errors outside the power of the 'Application', like network -- outages. . SAML.setHttpCachePolicy - . lookupRequestIdMiddleware + . lookupRequestIdMiddleware sparCtxLogger $ \sparCtxRequestId -> app Env {..} heavyLogOnly :: (Wai.Request, LByteString) -> Maybe (Wai.Request, LByteString) heavyLogOnly out@(req, _) = @@ -133,7 +136,12 @@ mkApp sparCtxOpts = do else Nothing pure (wrappedApp, let sparCtxRequestId = Bilge.RequestId "N/A" in Env {..}) -lookupRequestIdMiddleware :: (Bilge.RequestId -> Application) -> Application -lookupRequestIdMiddleware mkapp req cont = do - let reqid = RequestId . fromMaybe "N/A" $ lookupRequestId req - mkapp reqid req cont +lookupRequestIdMiddleware :: Logger -> (RequestId -> Wai.Application) -> Wai.Application +lookupRequestIdMiddleware logger mkapp req cont = do + case lookupRequestId req of + Just rid -> do + mkapp (RequestId rid) req cont + Nothing -> do + localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + Log.info logger $ "request-id" .= localRid ~~ "request" .= (show req) ~~ msg (val "generated a new request id for local request") + mkapp localRid req cont From 04320ca52bfd21ce22f58cd68e92cdc43cc49363 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 13 Dec 2023 17:02:21 +0000 Subject: [PATCH 12/20] fixes and clean up --- integration/test/API/Brig.hs | 15 ------------- integration/test/Test/Search.hs | 26 ----------------------- services/brig/src/Brig/Run.hs | 2 +- services/brig/src/Brig/User/API/Search.hs | 1 - services/cargohold/src/CargoHold/Run.hs | 2 +- services/spar/src/Spar/Run.hs | 2 +- 6 files changed, 3 insertions(+), 45 deletions(-) diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index bdc3660a68f..8e1c390862a 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -206,21 +206,6 @@ searchContacts :: domain -> App Response searchContacts user searchTerm domain = do - req <- baseRequest user Brig Versioned "/search/contacts" - q <- asString searchTerm - d <- objDomain domain - submit "GET" (req & addQueryParams [("q", q), ("domain", d)] & addHeader "Request-Id" "1234567890") - -searchContacts' :: - ( MakesValue user, - MakesValue searchTerm, - MakesValue domain - ) => - user -> - searchTerm -> - domain -> - App Response -searchContacts' user searchTerm domain = do req <- baseRequest user Brig Versioned "/search/contacts" q <- asString searchTerm d <- objDomain domain diff --git a/integration/test/Test/Search.hs b/integration/test/Test/Search.hs index 8540d372f9d..955afd744f1 100644 --- a/integration/test/Test/Search.hs +++ b/integration/test/Test/Search.hs @@ -217,29 +217,3 @@ testFederatedUserSearchForNonTeamUser = do [] -> pure () doc : _ -> assertFailure $ "Expected an empty result, but got " <> show doc <> " for test case " - -testX2 :: HasCallStack => App () -testX2 = do - u1 <- randomUser OwnDomain def {BrigI.team = True} - u2 <- randomUser OtherDomain def {BrigI.team = True} - team2 <- u2 %. "team" - GalleyI.setTeamFeatureStatus OtherDomain team2 "searchVisibilityInbound" "enabled" - - u2Handle <- API.randomHandle - bindResponse (BrigP.putHandle u2 u2Handle) $ assertSuccess - BrigI.refreshIndex OtherDomain - - void $ BrigP.searchContacts u1 u2Handle OtherDomain >>= getJSON 200 - -testX1 :: HasCallStack => App () -testX1 = do - u1 <- randomUser OwnDomain def {BrigI.team = True} - u2 <- randomUser OtherDomain def {BrigI.team = True} - team2 <- u2 %. "team" - GalleyI.setTeamFeatureStatus OtherDomain team2 "searchVisibilityInbound" "enabled" - - u2Handle <- API.randomHandle - bindResponse (BrigP.putHandle u2 u2Handle) $ assertSuccess - BrigI.refreshIndex OtherDomain - - void $ BrigP.searchContacts' u1 u2Handle OtherDomain >>= getJSON 200 diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 0ec61c98026..e0a27f327f6 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -166,7 +166,7 @@ lookupRequestIdMiddleware logger mkapp req cont = do Just rid -> do mkapp (RequestId rid) req cont Nothing -> do - localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom Log.info logger $ "request-id" .= localRid ~~ "request" .= (show req) ~~ msg (val "generated a new request id for local request") mkapp localRid req cont diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 310d54b5861..44a87a7dd50 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -72,7 +72,6 @@ search :: Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) search searcherId searchTerm maybeDomain maybeMaxResults = do - _ <- error "bäääääääm" -- FUTUREWORK(fisx): to reduce cassandra traffic, 'ensurePermissionsOrPersonalUser' could be -- run from `searchLocally` and `searchRemotely`, resp., where the team id is already -- available (at least in the local case) and can be passed as an argument rather than diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index cb26ea8c349..e997a88730c 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -103,7 +103,7 @@ mkApp o = Codensity $ \k -> lookupReqId l r = case lookup requestIdName $ Wai.requestHeaders r of Just rid -> pure $ RequestId rid Nothing -> do - localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom Log.info l $ "request-id" .= localRid ~~ "request" .= (show r) ~~ msg (val "generated a new request id for local request") pure localRid diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 460e13f9612..e8bd47f0a45 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -142,6 +142,6 @@ lookupRequestIdMiddleware logger mkapp req cont = do Just rid -> do mkapp (RequestId rid) req cont Nothing -> do - localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom Log.info logger $ "request-id" .= localRid ~~ "request" .= (show req) ~~ msg (val "generated a new request id for local request") mkapp localRid req cont From d0a8bb24c211d83e73a253f44209c507b75f9aff Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 13 Dec 2023 17:03:12 +0000 Subject: [PATCH 13/20] loglevel --- integration/test/Testlib/ModService.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index c8a2dd9f23d..e271bb3575d 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -216,7 +216,7 @@ startDynamicBackend resource beOverrides = do setLogLevel = def { sparCfg = setField "saml.logLevel" ("Warn" :: String), - brigCfg = setField "logLevel" ("Info" :: String), + brigCfg = setField "logLevel" ("Warn" :: String), cannonCfg = setField "logLevel" ("Warn" :: String), cargoholdCfg = setField "logLevel" ("Warn" :: String), galleyCfg = setField "logLevel" ("Warn" :: String), From c3258a7c7739065f9690f0c1c9e8e766e15448a8 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 14 Dec 2023 08:45:35 +0000 Subject: [PATCH 14/20] cu --- libs/wai-utilities/src/Network/Wai/Utilities/Server.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index e50247aa823..1226a363137 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -361,7 +361,6 @@ onError g m r k e = liftIO $ do when (code >= 500) $ either Prm.incCounter (counterIncr (path "net.errors")) `mapM_` m flushRequestBody r - Log.flush g k (jsonResponseToWai resp) -- | Log an 'Error' response for debugging purposes. From 0643998b40c3b3b2fda0b41d6ef0ec4bdbdf9bb5 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 14 Dec 2023 10:11:59 +0000 Subject: [PATCH 15/20] req id optional in be notif --- .../src/Wire/API/Federation/BackendNotifications.hs | 4 ++-- .../src/Wire/API/Federation/HasNotificationEndpoint.hs | 4 ++-- .../background-worker/src/Wire/BackendNotificationPusher.hs | 3 ++- .../test/Test/Wire/BackendNotificationPusherSpec.hs | 4 ++-- 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 9bcb9dbd083..b3cb2546ab4 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -33,7 +33,7 @@ data BackendNotification = BackendNotification -- pusher. This also makes development less clunky as we don't have to -- create a sum type here for all types of notifications that could exist. body :: RawJson, - requestId :: RequestId + requestId :: Maybe RequestId } deriving (Show, Eq) @@ -54,7 +54,7 @@ instance FromJSON BackendNotification where <*> o .: "targetComponent" <*> o .: "path" <*> (RawJson . TL.encodeUtf8 <$> o .: "body") - <*> o .: "requestId" + <*> o .:? "requestId" type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index ae841012a41..c2f5772a255 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -51,7 +51,7 @@ fedNotifToBackendNotif :: Domain -> Payload tag -> BackendNotification -fedNotifToBackendNotif mReqId ownDomain payload = +fedNotifToBackendNotif rid ownDomain payload = let p = T.pack . symbolVal $ Proxy @(NotificationPath tag) b = RawJson . encode $ payload in toNotif p b @@ -63,5 +63,5 @@ fedNotifToBackendNotif mReqId ownDomain payload = targetComponent = componentVal @(NotificationComponent k), path = path, body = body, - requestId = mReqId + requestId = Just rid } diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 5e139d06e0a..1fb6721eb58 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -7,6 +7,7 @@ import Control.Monad.Catch import Control.Retry import Data.Aeson qualified as A import Data.Domain +import Data.Id import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text @@ -96,7 +97,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do ceHttp2Manager <- asks http2Manager let ceOriginDomain = notif.ownDomain ceTargetDomain = targetDomain - ceOriginRequestId = notif.requestId + ceOriginRequestId = fromMaybe (RequestId "N/A") notif.requestId fcEnv = FederatorClientEnv {..} liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body lift $ ack envelope diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 3bb1cc5efb5..2a458b6990e 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -64,7 +64,7 @@ spec = do ownDomain = origDomain, path = "/on-user-deleted-connections", body = RawJson $ Aeson.encode notifContent, - requestId = RequestId "N/A" + requestId = Just $ RequestId "N/A" } envelope <- newMockEnvelope let msg = @@ -131,7 +131,7 @@ spec = do ownDomain = origDomain, path = "/on-user-deleted-connections", body = RawJson $ Aeson.encode notifContent, - requestId = RequestId "N/A" + requestId = Just $ RequestId "N/A" } envelope <- newMockEnvelope let msg = From 47211014f1d6899e15d054244768e67110957e08 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 14 Dec 2023 10:52:00 +0000 Subject: [PATCH 16/20] cu --- services/brig/src/Brig/Run.hs | 6 +++++- services/cannon/cannon.cabal | 1 + services/cannon/default.nix | 1 + services/cannon/src/Cannon/Types.hs | 26 ++++++++++++++++++------- services/cargohold/src/CargoHold/Run.hs | 6 +++++- 5 files changed, 31 insertions(+), 9 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index e0a27f327f6..4a5ed6239a6 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -167,7 +167,11 @@ lookupRequestIdMiddleware logger mkapp req cont = do mkapp (RequestId rid) req cont Nothing -> do localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom - Log.info logger $ "request-id" .= localRid ~~ "request" .= (show req) ~~ msg (val "generated a new request id for local request") + Log.info logger $ + "request-id" .= localRid + ~~ "method" .= Wai.requestMethod req + ~~ "path" .= Wai.rawPathInfo req + ~~ msg (val "generated a new request id for local request") mkapp localRid req cont customFormatters :: Servant.ErrorFormatters diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index 382fd4b8e04..3e6e2b138b0 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -107,6 +107,7 @@ library , types-common >=0.16 , unix , unliftio + , uuid , vector >=0.10 , wai >=3.0 , wai-extra >=3.0 diff --git a/services/cannon/default.nix b/services/cannon/default.nix index 2161483f93f..dce615c2001 100644 --- a/services/cannon/default.nix +++ b/services/cannon/default.nix @@ -87,6 +87,7 @@ mkDerivation { types-common unix unliftio + uuid vector wai wai-extra diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index 01f5b2a64a9..63dbdb42c37 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -45,13 +45,16 @@ import Cannon.Options import Cannon.WS (Clock, Key, Websocket) import Cannon.WS qualified as WS import Control.Concurrent.Async (mapConcurrently) -import Control.Lens +import Control.Lens ((^.)) import Control.Monad.Catch import Data.Metrics.Middleware import Data.Text.Encoding +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Imports import Network.Wai import Servant qualified +import System.Logger qualified as Log import System.Logger qualified as Logger import System.Logger.Class hiding (info) import System.Random.MWC (GenIO) @@ -111,16 +114,25 @@ mkEnv m external o l d p g t = WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) runCannon :: Env -> Cannon a -> Request -> IO a -runCannon e c r = - let e' = e {reqId = lookupReqId r} - in runCannon' e' c +runCannon e c r = do + rid <- lookupReqId e.applog r + let e' = e {reqId = rid} + runCannon' e' c runCannon' :: Env -> Cannon a -> IO a runCannon' e c = runReaderT (unCannon c) e -lookupReqId :: Request -> RequestId -lookupReqId = RequestId . fromMaybe "N/A" . lookup requestIdName . requestHeaders -{-# INLINE lookupReqId #-} +lookupReqId :: Logger -> Request -> IO RequestId +lookupReqId l r = case lookup requestIdName (requestHeaders r) of + Just rid -> pure $ RequestId rid + Nothing -> do + localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom + Log.info l $ + "request-id" .= localRid + ~~ "method" .= requestMethod r + ~~ "path" .= rawPathInfo r + ~~ msg (val "generated a new request id for local request") + pure localRid options :: Cannon Opts options = Cannon $ asks opts diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index e997a88730c..50513f2dcf9 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -104,7 +104,11 @@ mkApp o = Codensity $ \k -> Just rid -> pure $ RequestId rid Nothing -> do localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom - Log.info l $ "request-id" .= localRid ~~ "request" .= (show r) ~~ msg (val "generated a new request id for local request") + Log.info l $ + "request-id" .= localRid + ~~ "method" .= Wai.requestMethod r + ~~ "path" .= Wai.rawPathInfo r + ~~ msg (val "generated a new request id for local request") pure localRid toServantHandler :: Env -> Handler a -> Servant.Handler a From efe981ea19915f41e7a3df7422a1a1e009acc68e Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 14 Dec 2023 11:31:59 +0000 Subject: [PATCH 17/20] cu --- services/federator/default.nix | 1 + services/federator/federator.cabal | 1 + .../federator/src/Federator/ExternalServer.hs | 9 +++++--- .../unit/Test/Federator/ExternalServer.hs | 7 +++---- services/galley/src/Galley/Run.hs | 6 +++++- services/gundeck/src/Gundeck/Monad.hs | 21 ++++++++++++++----- 6 files changed, 32 insertions(+), 13 deletions(-) diff --git a/services/federator/default.nix b/services/federator/default.nix index 53f1495de50..0871b678a85 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -119,6 +119,7 @@ mkDerivation { transformers types-common unix + uuid wai wai-utilities warp diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 253bf26acfc..27b089fb9f9 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -146,6 +146,7 @@ library , transformers , types-common , unix + , uuid , wai , wai-utilities , warp diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index caac3b498a6..a8ce59635ed 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -36,6 +36,8 @@ import Data.Proxy (Proxy (Proxy)) import Data.Sequence qualified as Seq import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Data.X509 qualified as X509 import Federator.Discovery import Federator.Env @@ -117,7 +119,7 @@ server mgr intPort interpreter = API { status = Health.status mgr "internal server" intPort, externalRequest = \component rpc mReqId remoteDomain remoteCert -> - Tagged $ \req respond -> runCodensity (interpreter (callInward component rpc (fromMaybe (RequestId "N/A") mReqId) remoteDomain remoteCert req)) respond + Tagged $ \req respond -> runCodensity (interpreter (callInward component rpc mReqId remoteDomain remoteCert req)) respond } -- FUTUREWORK(federation): Versioning of the federation API. @@ -134,12 +136,13 @@ callInward :: ) => Component -> RPC -> - RequestId -> + Maybe RequestId -> Domain -> CertHeader -> Wai.Request -> Sem r Wai.Response -callInward component (RPC rpc) rid originDomain (CertHeader cert) wreq = do +callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do + rid <- liftIO $ maybe (RequestId . cs . UUID.toText <$> UUID.nextRandom) pure mReqId incomingCounterIncr originDomain -- only POST is supported when (Wai.requestMethod wreq /= HTTP.methodPost) $ diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index c65ccc4428f..2cfe4a49307 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -23,7 +23,6 @@ import Control.Monad.Codensity import Data.ByteString qualified as BS import Data.Default import Data.Domain -import Data.Id import Data.Text.Encoding qualified as Text import Federator.Discovery import Federator.Error.ServerError (ServerError (..)) @@ -138,7 +137,7 @@ requestBrigSuccess = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") (RequestId "N/A") aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls Wai.responseStatus res @?= HTTP.status200 @@ -166,7 +165,7 @@ requestBrigFailure = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") (RequestId "N/A") aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls @@ -196,7 +195,7 @@ requestGalleySuccess = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Galley (RPC "get-conversations") (RequestId "N/A") aValidDomain (CertHeader cert) request + $ callInward Galley (RPC "get-conversations") Nothing aValidDomain (CertHeader cert) request let expectedCall = Call Galley "/federation/get-conversations" "\"foo\"" aValidDomain embed $ assertEqual "one call to galley should be made" [expectedCall] actualCalls embed $ Wai.responseStatus res @?= HTTP.status200 diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 252f7800cba..f756b9f98c9 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -133,7 +133,11 @@ mkApp opts = Just rid -> pure $ RequestId rid Nothing -> do localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom - Log.info l $ "request-id" .= localRid ~~ "request" .= (show r) ~~ msg (val "generated a new request id for local request") + Log.info l $ + "request-id" .= localRid + ~~ "method" .= requestMethod r + ~~ "path" .= rawPathInfo r + ~~ msg (val "generated a new request id for local request") pure localRid closeApp :: Env -> IO () diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 6f9b14bed4a..809c7192d1d 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -48,10 +48,12 @@ import Cassandra import Control.Concurrent.Async (AsyncCancelled) import Control.Error import Control.Exception (throwIO) -import Control.Lens +import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch hiding (tryJust) import Data.Aeson (FromJSON) import Data.Misc (Milliseconds (..)) +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Database.Redis qualified as Redis import Gundeck.Env import Gundeck.Redis qualified as Redis @@ -163,7 +165,8 @@ instance HasRequestId Gundeck where runGundeck :: Env -> Request -> Gundeck ResponseReceived -> IO ResponseReceived runGundeck e r m = do - let e' = e & reqId .~ lookupReqId r + rid <- lookupReqId e._applog r + let e' = e & reqId .~ rid runDirect e' m runDirect :: Env -> Gundeck a -> IO a @@ -180,9 +183,17 @@ runDirect e m = throwIO exception ) -lookupReqId :: Request -> RequestId -lookupReqId = RequestId . fromMaybe "N/A" . lookup requestIdName . requestHeaders -{-# INLINE lookupReqId #-} +lookupReqId :: Logger -> Request -> IO RequestId +lookupReqId l r = case lookup requestIdName (requestHeaders r) of + Just rid -> pure $ RequestId rid + Nothing -> do + localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom + Log.info l $ + "request-id" .= localRid + ~~ "method" .= requestMethod r + ~~ "path" .= rawPathInfo r + ~~ msg (val "generated a new request id for local request") + pure localRid fromJsonBody :: FromJSON a => JsonRequest a -> Gundeck a fromJsonBody r = exceptT (throwM . mkError status400 "bad-request") pure (parseBody r) From c36c4d5e48ae86b12fd1bdc3982a4c6f62d677c3 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 14 Dec 2023 11:48:55 +0000 Subject: [PATCH 18/20] cu --- services/proxy/default.nix | 2 ++ services/proxy/proxy.cabal | 1 + services/proxy/src/Proxy/Proxy.hs | 20 +++++++++++++++++--- 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/services/proxy/default.nix b/services/proxy/default.nix index ee08f5dd212..8c5360ccdca 100644 --- a/services/proxy/default.nix +++ b/services/proxy/default.nix @@ -25,6 +25,7 @@ , tinylog , types-common , unliftio-core +, uuid , wai , wai-predicates , wai-routing @@ -58,6 +59,7 @@ mkDerivation { tinylog types-common unliftio-core + uuid wai wai-predicates wai-routing diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index 7a5cee12e01..bf8ef051525 100644 --- a/services/proxy/proxy.cabal +++ b/services/proxy/proxy.cabal @@ -94,6 +94,7 @@ library , tinylog >=0.12 , types-common >=0.8 , unliftio-core + , uuid , wai >=3.2 , wai-predicates >=0.8 , wai-routing >=0.12 diff --git a/services/proxy/src/Proxy/Proxy.hs b/services/proxy/src/Proxy/Proxy.hs index a50ae884c63..9cbb5d20899 100644 --- a/services/proxy/src/Proxy/Proxy.hs +++ b/services/proxy/src/Proxy/Proxy.hs @@ -28,9 +28,12 @@ import Control.Lens hiding ((.=)) import Control.Monad.Catch import Control.Monad.IO.Unlift () import Data.Id (RequestId (..)) +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Imports import Network.Wai import Proxy.Env +import System.Logger qualified as Log import System.Logger qualified as Logger import System.Logger.Class hiding (Error, info) @@ -53,11 +56,22 @@ instance MonadLogger Proxy where log l m = ask >>= \e -> Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) runProxy :: Env -> Request -> Proxy ResponseReceived -> IO ResponseReceived -runProxy e r m = runReaderT (unProxy m) (reqId .~ lookupReqId r $ e) +runProxy e r m = do + rid <- lookupReqId (e ^. applog) r + runReaderT (unProxy m) (reqId .~ rid $ e) reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -lookupReqId :: Request -> RequestId -lookupReqId = RequestId . fromMaybe "N/A" . lookup requestIdName . requestHeaders +lookupReqId :: Logger -> Request -> IO RequestId +lookupReqId l r = case lookup requestIdName (requestHeaders r) of + Just rid -> pure $ RequestId rid + Nothing -> do + localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom + Log.info l $ + "request-id" .= localRid + ~~ "method" .= requestMethod r + ~~ "path" .= rawPathInfo r + ~~ msg (val "generated a new request id for local request") + pure localRid From 13c2fcb71c71893b3fb6ca320b4592889fcb7991 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 14 Dec 2023 11:59:43 +0000 Subject: [PATCH 19/20] cu --- .../federator/src/Federator/ExternalServer.hs | 13 +++++++++++- .../federator/src/Federator/InternalServer.hs | 21 +++++++++++++++---- .../unit/Test/Federator/InternalServer.hs | 5 ++--- 3 files changed, 31 insertions(+), 8 deletions(-) diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index a8ce59635ed..37a1ebb678a 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -62,10 +62,12 @@ import Servant.API.Extended.Endpath import Servant.Client.Core import Servant.Server (Tagged (..)) import Servant.Server.Generic +import System.Logger (msg, val, (.=), (~~)) import System.Logger.Message qualified as Log import Wire.API.Federation.Component import Wire.API.Federation.Domain import Wire.API.Routes.FederationDomainConfig +import Wire.Sem.Logger (info) -- | Used to get PEM encoded certificate out of an HTTP header newtype CertHeader = CertHeader X509.Certificate @@ -142,7 +144,16 @@ callInward :: Wai.Request -> Sem r Wai.Response callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do - rid <- liftIO $ maybe (RequestId . cs . UUID.toText <$> UUID.nextRandom) pure mReqId + rid <- case mReqId of + Just r -> pure r + Nothing -> do + localRid <- liftIO $ RequestId . cs . UUID.toText <$> UUID.nextRandom + info $ + "request-id" .= localRid + ~~ "method" .= Wai.requestMethod wreq + ~~ "path" .= Wai.rawPathInfo wreq + ~~ msg (val "generated a new request id for local request") + pure localRid incomingCounterIncr originDomain -- only POST is supported when (Wai.requestMethod wreq /= HTTP.methodPost) $ diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index 7de3ef3843c..13dd401f3b6 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -27,6 +27,8 @@ import Data.Domain import Data.Id import Data.Metrics.Servant qualified as Metrics import Data.Proxy +import Data.UUID as UUID +import Data.UUID.V4 as UUID import Federator.Env import Federator.Error.ServerError import Federator.Health qualified as Health @@ -46,10 +48,11 @@ import Servant.API import Servant.API.Extended.Endpath import Servant.Server (Tagged (..)) import Servant.Server.Generic +import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class qualified as Log import Wire.API.Federation.Component import Wire.API.Routes.FederationDomainConfig -import Wire.Sem.Logger (Logger, debug) +import Wire.Sem.Logger (Logger, debug, info) data API mode = API { status :: @@ -92,7 +95,7 @@ server mgr extPort interpreter = API { status = Health.status mgr "external server" extPort, internalRequest = \mReqId remoteDomain component rpc -> - Tagged $ \req respond -> runCodensity (interpreter (callOutward (fromMaybe (RequestId "N/A") mReqId) remoteDomain component rpc req)) respond + Tagged $ \req respond -> runCodensity (interpreter (callOutward mReqId remoteDomain component rpc req)) respond } callOutward :: @@ -104,13 +107,23 @@ callOutward :: Member Metrics r, Member (Logger (Log.Msg -> Log.Msg)) r ) => - RequestId -> + Maybe RequestId -> Domain -> Component -> RPC -> Wai.Request -> Sem r Wai.Response callOutward mReqId targetDomain component (RPC path) req = do + rid <- case mReqId of + Just r -> pure r + Nothing -> do + localRid <- liftIO $ RequestId . cs . UUID.toText <$> UUID.nextRandom + info $ + "request-id" .= localRid + ~~ "method" .= Wai.requestMethod req + ~~ "path" .= Wai.rawPathInfo req + ~~ msg (val "generated a new request id for local request") + pure localRid -- only POST is supported when (Wai.requestMethod req /= HTTP.methodPost) $ throw InvalidRoute @@ -128,7 +141,7 @@ callOutward mReqId targetDomain component (RPC path) req = do . Log.field "body" body resp <- discoverAndCall - mReqId + rid targetDomain component path diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 5756c86be3e..3fb41d2d869 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -23,7 +23,6 @@ import Data.ByteString.Builder import Data.ByteString.Conversion import Data.Default import Data.Domain -import Data.Id import Federator.Error.ServerError import Federator.InternalServer (callOutward) import Federator.Metrics @@ -103,7 +102,7 @@ federatedRequestSuccess = . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "target.example.com") FullSearch FederationRestrictionAllowAll] 10) . assertMetrics - $ callOutward (RequestId "N/A") targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request Wai.responseStatus res @?= HTTP.status200 body <- Wai.lazyResponseBody res body @?= "\"bar\"" @@ -149,7 +148,7 @@ federatedRequestFailureAllowList = . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "hello.world") FullSearch FederationRestrictionAllowAll] 10) . interpretMetricsEmpty - $ callOutward (RequestId "N/A") targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request eith @?= Left (FederationDenied targetDomain) -- @END From 53847b8789b57cfed63418026ee05041519742ec Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 14 Dec 2023 14:43:49 +0000 Subject: [PATCH 20/20] fix galley --- services/galley/src/Galley/Run.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index f756b9f98c9..b9643cf7af2 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -132,7 +132,7 @@ mkApp opts = lookupReqId l r = case lookup requestIdName $ requestHeaders r of Just rid -> pure $ RequestId rid Nothing -> do - localRid <- RequestId . cs . UUID.toByteString <$> UUID.nextRandom + localRid <- RequestId . cs . UUID.toText <$> UUID.nextRandom Log.info l $ "request-id" .= localRid ~~ "method" .= requestMethod r