wireapp · stefanwire · Sep 3, 2024
diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs
@@ -31,6 +31,7 @@ import Notifications
 import SetupHelpers
 import Test.Version
 import Testlib.Prelude
+import Testlib.VersionedFed
 
 testGetMLSOne2One :: (HasCallStack) => Version5 -> Domain -> App ()
 testGetMLSOne2One v otherDomain = withVersion5 v $ do
@@ -304,3 +305,42 @@ testMLSGhostOne2OneConv = do
     createCommit
     liftIO $ putMVar doneVar ()
     wait a
+
+testMLSFederationV1 :: App ()
+testMLSFederationV1 = do
+  alice <- randomUser OwnDomain def
+  bob <- randomUser (StaticFedDomain 1) def
+  connectUsers [alice, bob]
+  bobDomainStr <- asString (StaticFedDomain 1)
+  let assertConvData conv = do
+        conv %. "epoch" `shouldMatchInt` 0
+        assertFieldMissing conv "cipher_suite"
+
+  mlsOne2OneConv <-
+    getMLSOne2OneConversation alice bob `bindResponse` \resp -> do
+      one2oneConv <- getJSON 200 resp
+      convOwnerDomain <- asString $ one2oneConv %. "conversation.qualified_id.domain"
+      let user = if convOwnerDomain == bobDomainStr then bob else alice
+      ownerDomainPublicKeys <- getMLSPublicKeys user >>= getJSON 200
+
+      one2oneConv %. "public_keys" `shouldMatch` ownerDomainPublicKeys
+
+      conv <- one2oneConv %. "conversation"
+      conv %. "type" `shouldMatchInt` 2
+      shouldBeEmpty (conv %. "members.others")
+      conv %. "members.self.conversation_role" `shouldMatch` "wire_member"
+      conv %. "members.self.qualified_id" `shouldMatch` (alice %. "qualified_id")
+      assertConvData conv
+
+      pure one2oneConv
+
+  -- check that the conversation has the same ID on the other side
+  mlsOne2OneConv2 <- bindResponse (getMLSOne2OneConversation bob alice) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    resp.json
+
+  conv2 <- mlsOne2OneConv2 %. "conversation"
+  conv2 %. "type" `shouldMatchInt` 2
+  conv2 %. "qualified_id" `shouldMatch` (mlsOne2OneConv %. "conversation.qualified_id")
+  mlsOne2OneConv2 %. "public_keys" `shouldMatch` (mlsOne2OneConv %. "public_keys")
+  assertConvData conv2
diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs
@@ -307,7 +307,7 @@ mkFailureResponse status domain path body
 -- | Run federator client synchronously.
 runFederatorClient ::
   FederatorClientEnv ->
-  FederatorClient c a ->
+  (Version -> FederatorClient c a) ->
   IO (Either FederatorClientError a)
 runFederatorClient env =
   lowerCodensity
@@ -325,16 +325,16 @@ runVersionedFederatorClient venv =
 runFederatorClientToCodensity ::
   forall c a.
   FederatorClientEnv ->
-  FederatorClient c a ->
+  (Version -> FederatorClient c a) ->
   Codensity IO (Either FederatorClientError a)
-runFederatorClientToCodensity env action = runExceptT $ do
+runFederatorClientToCodensity env mkAction = runExceptT $ do
   v <-
     runVersionedFederatorClientToCodensity
       (FederatorClientVersionedEnv env Nothing)
       (versionNegotiation supportedVersions)
   runVersionedFederatorClientToCodensity @c
     (FederatorClientVersionedEnv env (Just v))
-    action
+    (mkAction v)
 
 runVersionedFederatorClientToCodensity ::
   FederatorClientVersionedEnv ->

diff --git a/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs b/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs
@@ -42,7 +42,8 @@ interpretFederationAPIAccess config action = do
                       ceHttp2Manager = config.http2Manager,
                       ceOriginRequestId = config.requestId
                     }
-            embed . fmap (first FederationCallFailure) $ runFederatorClient ce rpc
+            -- FUTUREWORK: remove this 'const' and take rpc as 'Version ->  FederatorClient c a'
+            embed . fmap (first FederationCallFailure) $ runFederatorClient ce (const $ rpc)
   interpretFederationAPIAccessGeneral runner (pure isFederationConfigured) action
 
 interpretFederationAPIAccessGeneral ::

diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs
@@ -209,5 +209,6 @@ runBrigFederatorClient targetDomain action = do
             ceHttp2Manager = mgr,
             ceOriginRequestId = rid
           }
-  liftIO (runFederatorClient env action)
+  -- FUTUREWORK: remove this 'const' and take action as 'Version ->  FederatorClient Brig a'
+  liftIO (runFederatorClient env (const action))
     >>= either (throwE . FederationCallFailure) pure
diff --git a/services/cargohold/src/CargoHold/Federation.hs b/services/cargohold/src/CargoHold/Federation.hs
@@ -93,7 +93,7 @@ mkFederatorClientEnv remote = do
 executeFederated :: Remote x -> FederatorClient 'Cargohold a -> Handler a
 executeFederated remote c = do
   env <- mkFederatorClientEnv remote
-  liftIO (runFederatorClient @'Cargohold env c)
+  liftIO (runFederatorClient @'Cargohold env (const c))
     >>= either (throwE . federationErrorToWai . FederationCallFailure) pure
 
 executeFederatedStreaming ::
@@ -114,5 +114,5 @@ executeFederatedStreaming remote c = do
   pure $
     SourceT $ \k ->
       runCodensity
-        (runFederatorClientToCodensity @'Cargohold env c)
+        (runFederatorClientToCodensity @'Cargohold env (const c))
         (either (throw . federationErrorToWai . FederationCallFailure) (flip unSourceT k))
diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs
@@ -99,7 +99,7 @@ withMockFederatorClient mock action = withTempMockFederator mock $ \port -> do
             ceHttp2Manager = mgr,
             ceOriginRequestId = RequestId "N/A"
           }
-  a <- runFederatorClient env action
+  a <- runFederatorClient env (const action)
   case a of
     Left (FederatorClientError r) -> pure (Left (ResponseFailure r))
     Left err -> assertFailure $ "Unexpected client error: " <> displayException err
@@ -204,7 +204,7 @@ testClientConnectionError = do
             ceHttp2Manager = mgr,
             ceOriginRequestId = RequestId "N/A"
           }
-  result <- runFederatorClient env (fedClient @'Brig @"get-user-by-handle" handle)
+  result <- runFederatorClient env (\_version -> fedClient @'Brig @"get-user-by-handle" handle)
   case result of
     Left (FederatorClientHTTP2Error (FederatorClientConnectionError _)) -> pure ()
     Left x -> assertFailure $ "Expected connection error, got: " <> show x

diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs
@@ -351,7 +351,7 @@ getFederationStatus req = do
     . (ensureNoUnreachableBackends =<<)
     $ E.runFederatedConcurrentlyEither
       (Set.toList req.rdDomains)
-      ( \qds ->
+      ( \qds _version ->
           fedClient @'Brig @"get-not-fully-connected-backends"
             (DomainSet . Set.map tDomain $ void qds `Set.delete` req.rdDomains)
       )
@@ -539,7 +539,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do
         then checkFederationStatus (RemoteDomains (invitedRemoteDomains <> existingRemoteDomains))
         else -- even if there are no new remotes, we still need to check they are reachable
         void . (ensureNoUnreachableBackends =<<) $
-          E.runFederatedConcurrentlyEither @_ @'Brig invitedRemoteUsers $ \_ ->
+          E.runFederatedConcurrentlyEither @_ @'Brig invitedRemoteUsers $ \_ _ ->
             pure ()
 
     conv :: Data.Conversation
@@ -1068,7 +1068,7 @@ notifyTypingIndicator conv qusr mcon ts = do
             typingStatus = ts
           }
 
-  void $ E.runFederatedConcurrentlyEither (fmap rmId remoteMemsOther) $ \rmems -> do
+  void $ E.runFederatedConcurrentlyEither (fmap rmId remoteMemsOther) $ \rmems _version -> do
     fedClient @'Galley @"on-typing-indicator-updated" (tdu (tUnqualified rmems))
 
   pure (tdu (fmap (tUnqualified . rmId) remoteMemsOrig))

diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/services/galley/src/Galley/API/MLS/Commit/Core.hs
@@ -163,7 +163,7 @@ getRemoteMLSClients rusr suite = do
           { userId = tUnqualified rusr,
             cipherSuite = tagCipherSuite suite
           }
-  runFederatedEither rusr $
+  runFederatedEither rusr $ \_version ->
     fedClient @'Brig @"get-mls-clients" mcr
       <|> fedClient @'Brig @(Versioned 'V0 "get-mls-clients") (mlsClientsRequestToV0 mcr)
 

diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/services/galley/src/Galley/API/MLS/GroupInfo.hs
@@ -91,7 +91,7 @@ getGroupInfoFromRemoteConv lusr rcnv = do
           { sender = tUnqualified lusr,
             conv = tUnqualified rcnv
           }
-  response <- E.runFederated rcnv (fedClient @'Galley @"query-group-info" getRequest)
+  response <- E.runFederated rcnv (\_version -> fedClient @'Galley @"query-group-info" getRequest)
   case response of
     GetGroupInfoResponseError e -> rethrowErrors @MLSGroupInfoStaticErrors e
     GetGroupInfoResponseState s ->

diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs
@@ -298,7 +298,7 @@ postMLSCommitBundleToRemoteConv loc qusr c con bundle ctype rConvOrSubId = do
     flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) ((.conv) <$> rConvOrSubId)
 
   resp <-
-    runFederated rConvOrSubId $
+    runFederated rConvOrSubId $ \_version ->
       fedClient @'Galley @"send-mls-commit-bundle" $
         MLSMessageSendRequest
           { convOrSubId = tUnqualified rConvOrSubId,
@@ -440,7 +440,7 @@ postMLSMessageToRemoteConv loc qusr senderClient con msg rConvOrSubId = do
   flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) ((.conv) <$> rConvOrSubId)
 
   resp <-
-    runFederated rConvOrSubId $
+    runFederated rConvOrSubId $ \_version ->
       fedClient @'Galley @"send-mls-message" $
         MLSMessageSendRequest
           { convOrSubId = tUnqualified rConvOrSubId,

diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/services/galley/src/Galley/API/MLS/Migration.hs
@@ -72,6 +72,6 @@ checkMigrationCriteria now conv ws
     remoteUsersMigrated = ApAll $ do
       remoteProfiles <- fmap (foldMap tUnqualified)
         . runFederatedConcurrently (map rmId conv.mcRemoteMembers)
-        $ \ruids ->
+        $ \ruids _version ->
           fedClient @'Brig @"get-users-by-ids" (tUnqualified ruids)
       pure $ all (containsMLS . profileSupportedProtocols) remoteProfiles
diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs
@@ -149,7 +149,7 @@ getRemoteSubConversation ::
   SubConvId ->
   Sem r PublicSubConversation
 getRemoteSubConversation lusr rcnv sconv = do
-  res <- runFederated rcnv $ do
+  res <- runFederated rcnv $ \_version ->
     fedClient @'Galley @"get-sub-conversation" $
       GetSubConversationsRequest
         { gsreqUser = tUnqualified lusr,
@@ -317,7 +317,7 @@ deleteRemoteSubConversation lusr rcnvId scnvId dsc = do
   response <-
     runFederated
       rcnvId
-      (fedClient @'Galley @"delete-sub-conversation" deleteRequest)
+      (\_version -> fedClient @'Galley @"delete-sub-conversation" deleteRequest)
   case response of
     DeleteSubConversationResponseError e -> rethrowErrors @MLSDeleteSubConvStaticErrors e
     DeleteSubConversationResponseSuccess -> pure ()
@@ -428,7 +428,7 @@ leaveRemoteSubConversation ::
   Sem r ()
 leaveRemoteSubConversation cid rcnv sub = do
   res <-
-    runFederated rcnv $
+    runFederated rcnv $ \_version ->
       fedClient @'Galley @"leave-sub-conversation" $
         LeaveSubConversationRequest
           { lscrUser = ciUser cid,

diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/services/galley/src/Galley/API/MLS/Welcome.hs
@@ -114,7 +114,7 @@ sendRemoteWelcomes ::
   Sem r ()
 sendRemoteWelcomes qcnv qusr welcome clients = do
   let msg = Base64ByteString welcome.raw
-  traverse_ handleError <=< runFederatedConcurrentlyEither clients $ \rcpts ->
+  traverse_ handleError <=< runFederatedConcurrentlyEither clients $ \rcpts _version ->
     fedClient @'Galley @"mls-welcome"
       MLSWelcomeRequest
         { originatingUser = qUnqualified qusr,

diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs
@@ -80,6 +80,7 @@ import Wire.API.Federation.API.Brig
 import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Client (FederatorClient)
 import Wire.API.Federation.Error
+import Wire.API.Federation.Version qualified as Fed
 import Wire.API.Message
 import Wire.API.Routes.Public.Galley.Messaging
 import Wire.API.Team.LegalHold
@@ -227,8 +228,8 @@ getRemoteClients remoteMembers =
   -- which domains and users aren't contactable at the moment.
   tUnqualified <$$$> runFederatedConcurrentlyEither (map rmId remoteMembers) getRemoteClientsFromDomain
   where
-    getRemoteClientsFromDomain :: Remote [UserId] -> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId))
-    getRemoteClientsFromDomain (tUntagged -> Qualified uids domain) =
+    getRemoteClientsFromDomain :: Remote [UserId] -> Fed.Version -> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId))
+    getRemoteClientsFromDomain (tUntagged -> Qualified uids domain) _version =
       Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap
         <$> fedClient @'Brig @"get-user-clients" (GetUserClients uids)
 
@@ -245,7 +246,7 @@ postRemoteOtrMessage sender conv rawMsg = do
             sender = qUnqualified (tUntagged sender),
             rawMessage = Base64ByteString rawMsg
           }
-      rpc = fedClient @'Galley @"send-message" msr
+      rpc _version = fedClient @'Galley @"send-message" msr
   (.response) <$> runFederated conv rpc
 
 postBroadcast ::

diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs
@@ -95,6 +95,7 @@ import Wire.API.Federation.API
 import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Client (FederatorClient)
 import Wire.API.Federation.Error
+import Wire.API.Federation.Version qualified as Fed
 import Wire.API.Provider.Bot qualified as Public
 import Wire.API.Routes.MultiTablePaging qualified as Public
 import Wire.API.Team.Feature as Public
@@ -252,8 +253,8 @@ getRemoteConversationsWithFailures lusr convs = do
         | otherwise = [failedGetConversationLocally (map tUntagged locallyNotFound)]
 
   -- request conversations from remote backends
-  let rpc :: GetConversationsRequest -> FederatorClient 'Galley GetConversationsResponse
-      rpc = fedClient @'Galley @"get-conversations"
+  let rpc :: GetConversationsRequest -> Fed.Version -> FederatorClient 'Galley GetConversationsResponse
+      rpc req _version = fedClient @'Galley @"get-conversations" req
   resp <-
     E.runFederatedConcurrentlyEither locallyFound $ \someConvs ->
       rpc $ GetConversationsRequest (tUnqualified lusr) (tUnqualified someConvs)
@@ -785,7 +786,7 @@ getRemoteMLSOne2OneConversation lself qother rconv = do
       else throw (InternalErrorWithDescription "Unexpected 1-1 conversation domain")
 
   resp <-
-    E.runFederated rconv $
+    E.runFederated rconv $ \_version ->
       fedClient @'Galley @"get-one2one-conversation" $
         GetOne2OneConversationRequest (tUnqualified lself) (tUnqualified rother)
   case resp of

diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs
@@ -372,7 +372,7 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do
             convId = tUnqualified rcnv,
             action = SomeConversationAction (sing @tag) action
           }
-  response <- E.runFederated rcnv (fedClient @'Galley @"update-conversation" updateRequest)
+  response <- E.runFederated rcnv (\_version -> fedClient @'Galley @"update-conversation" updateRequest)
   convUpdate <- case response of
     ConversationUpdateResponseNoChanges -> throw NoChanges
     ConversationUpdateResponseError err' -> raise $ rethrowErrors @(HasConversationActionGalleyErrors tag) err'
@@ -1184,8 +1184,8 @@ removeMemberFromRemoteConv ::
 removeMemberFromRemoteConv cnv lusr victim
   | tUntagged lusr == victim = do
       let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim)
-      let rpc = fedClient @'Galley @"leave-conversation" lc
-      E.runFederated cnv rpc
+      let mkRpc _version = fedClient @'Galley @"leave-conversation" lc
+      E.runFederated cnv mkRpc
         >>= either handleError handleSuccess . void . (.response)
   | otherwise = throwS @('ActionDenied 'RemoveConversationMember)
   where
@@ -1505,7 +1505,7 @@ memberTyping lusr zcon qcnv ts = do
                   userId = tUnqualified lusr,
                   convId = tUnqualified rcnv
                 }
-        res <- E.runFederated rcnv (fedClient @'Galley @"update-typing-indicator" rpc)
+        res <- E.runFederated rcnv (\_version -> fedClient @'Galley @"update-typing-indicator" rpc)
         case res of
           TypingDataUpdateSuccess (TypingDataUpdated {..}) -> do
             pushTypingIndicatorEvents origUserId time usersInConv (Just zcon) qcnv typingStatus

diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs
@@ -840,13 +840,13 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do
 
   -- ping involved remote backends
   void . (ensureNoUnreachableBackends =<<) $
-    runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ ->
+    runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ _ ->
       void $ fedClient @'Brig @"api-version" ()
 
   void . (ensureNoUnreachableBackends =<<) $
     -- let remote backends know about a subset of new joiners
     runFederatedConcurrentlyEither allRemoteMembersQualified $
-      \rrms ->
+      \rrms _version ->
         fedClient @'Galley @"on-conversation-created"
           ( rc
               { nonCreatorMembers =

diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs
@@ -35,28 +35,29 @@ import Polysemy
 import Wire.API.Federation.Client
 import Wire.API.Federation.Component
 import Wire.API.Federation.Error
+import Wire.API.Federation.Version
 
 data FederatorAccess m a where
   RunFederated ::
     (KnownComponent c) =>
     Remote x ->
-    FederatorClient c a ->
+    (Version -> FederatorClient c a) ->
     FederatorAccess m a
   RunFederatedEither ::
     (KnownComponent c) =>
     Remote x ->
-    FederatorClient c a ->
+    (Version -> FederatorClient c a) ->
     FederatorAccess m (Either FederationError a)
   RunFederatedConcurrently ::
     (KnownComponent c, Foldable f, Functor f) =>
     f (Remote x) ->
-    (Remote [x] -> FederatorClient c a) ->
+    (Remote [x] -> Version -> FederatorClient c a) ->
     FederatorAccess m [Remote a]
   RunFederatedConcurrentlyEither ::
     forall (c :: Component) f a m x.
     (KnownComponent c, Foldable f, Functor f) =>
     f (Remote x) ->
-    (Remote [x] -> FederatorClient c a) ->
+    (Remote [x] -> Version -> FederatorClient c a) ->
     FederatorAccess m [Either (Remote [x], FederationError) (Remote a)]
   -- | An action similar to 'RunFederatedConcurrentlyEither', but whose input is
   -- already in buckets. The buckets are paired with arbitrary data that affect
@@ -65,7 +66,7 @@ data FederatorAccess m a where
     forall (c :: Component) f a m x.
     (KnownComponent c, Foldable f) =>
     f (Remote x) ->
-    (Remote x -> FederatorClient c a) ->
+    (Remote x -> Version -> FederatorClient c a) ->
     FederatorAccess m [Either (Remote x, FederationError) (Remote a)]
   IsFederationConfigured :: FederatorAccess m Bool