diff --git a/changelog.d/6-federation/receipt-mode b/changelog.d/6-federation/receipt-mode new file mode 100644 index 0000000000..53da2e3e9b --- /dev/null +++ b/changelog.d/6-federation/receipt-mode @@ -0,0 +1 @@ +Implement remote admin action: Update receipt mode diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 33db087804..b6ca885338 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -31,6 +31,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Action import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role (RoleName) +import Wire.API.Error.Galley import Wire.API.Federation.API.Common import Wire.API.Federation.Endpoint import Wire.API.Message @@ -57,6 +58,7 @@ type GalleyApi = -- this backend :<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse :<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse + :<|> FedEndpoint "update-conversation" ConversationUpdateRequest ConversationUpdateResponse data GetConversationsRequest = GetConversationsRequest { gcrUserId :: UserId, @@ -229,3 +231,25 @@ data UserDeletedConversationsNotification = UserDeletedConversationsNotification deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserDeletedConversationsNotification) deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedConversationsNotification) + +data ConversationUpdateRequest = ConversationUpdateRequest + { -- | The user that is attempting to perform the action. This is qualified + -- implicitly by the origin domain + curUser :: UserId, + -- | Id of conversation the action should be performed on. The is qualified + -- implicity by the owning backend which receives this request. + curConvId :: ConvId, + curAction :: SomeConversationAction + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform ConversationUpdateRequest) + deriving (FromJSON, ToJSON) via (CustomEncoded ConversationUpdateRequest) + +data ConversationUpdateResponse + = ConversationUpdateResponseError GalleyError + | ConversationUpdateResponseUpdate ConversationUpdate + | ConversationUpdateResponseNoChanges + deriving stock (Eq, Show, Generic) + deriving + (ToJSON, FromJSON) + via (CustomEncoded ConversationUpdateResponse) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index 50fbcfa5b1..a33228dfcb 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -140,6 +140,8 @@ data FederationError -- indicate a bug in either backend, or an incompatibility in the -- server-to-server API. FederationUnexpectedBody Text + | -- | Federator client got an unexpected error response from remote backend + FederationUnexpectedError Text deriving (Show, Typeable) instance Exception FederationError @@ -152,6 +154,7 @@ federationErrorToWai FederationNotImplemented = federationNotImplemented federationErrorToWai FederationNotConfigured = federationNotConfigured federationErrorToWai (FederationCallFailure err) = federationClientErrorToWai err federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s +federationErrorToWai (FederationUnexpectedError t) = federationUnexpectedError t federationClientErrorToWai :: FederatorClientError -> Wai.Error federationClientErrorToWai (FederatorClientHTTP2Error e) = @@ -276,6 +279,13 @@ federationUnexpectedBody msg = "federation-unexpected-body" ("Could parse body, but response was not expected: " <> LT.fromStrict msg) +federationUnexpectedError :: Text -> Wai.Error +federationUnexpectedError msg = + Wai.mkError + unexpectedFederationResponseStatus + "federation-unexpected-wai-error" + ("Could parse body, but got an unexpected error response: " <> LT.fromStrict msg) + federationNotConfigured :: Wai.Error federationNotConfigured = Wai.mkError diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index a52cb9ca30..39425db603 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -14,6 +14,9 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Wire.API.Error.Galley ( GalleyError (..), @@ -27,6 +30,8 @@ module Wire.API.Error.Galley where import Control.Lens ((%~)) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Singletons.CustomStar (genSingletons) import Data.Singletons.Prelude (Show_) import qualified Data.Swagger as S import Data.Tagged @@ -40,6 +45,7 @@ import Wire.API.Error import qualified Wire.API.Error.Brig as BrigError import Wire.API.Routes.API import Wire.API.Team.Permission +import Wire.API.Util.Aeson (CustomEncoded (..)) data GalleyError = InvalidAction @@ -100,6 +106,10 @@ data GalleyError | TooManyTeamMembersOnTeamWithLegalhold | NoLegalHoldDeviceAllocated | UserLegalHoldNotPending + deriving (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (CustomEncoded GalleyError) + +$(genSingletons [''GalleyError]) instance KnownError (MapError e) => IsSwaggerError (e :: GalleyError) where addToSwagger = addStaticErrorToSwagger @(MapError e) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Util.hs b/libs/wire-api/src/Wire/API/Routes/Public/Util.hs index d76a730f73..1071ef5221 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Util.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Util.hs @@ -60,6 +60,7 @@ type ResponsesForExistedCreated eDesc cDesc a = data UpdateResult a = Unchanged | Updated !a + deriving (Functor) type UpdateResponses unchangedDesc updatedDesc a = '[ RespondEmpty 204 unchangedDesc, diff --git a/libs/wire-api/src/Wire/API/Team/Permission.hs b/libs/wire-api/src/Wire/API/Team/Permission.hs index d576c1863a..43dd13189b 100644 --- a/libs/wire-api/src/Wire/API/Team/Permission.hs +++ b/libs/wire-api/src/Wire/API/Team/Permission.hs @@ -58,6 +58,7 @@ import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Imports import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) +import Wire.API.Util.Aeson (CustomEncoded (..)) -------------------------------------------------------------------------------- -- Permissions @@ -151,6 +152,7 @@ data Perm -- read Note [team roles] first. deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) deriving (Arbitrary) via (GenericUniform Perm) + deriving (FromJSON, ToJSON) via (CustomEncoded Perm) permsToInt :: Set Perm -> Word64 permsToInt = Set.foldr' (\p n -> n .|. permToInt p) 0 diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 262231e90d..a417556778 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -21,6 +21,7 @@ module Galley.API.Action ConversationJoin (..), ConversationMemberUpdate (..), HasConversationActionEffects, + HasConversationActionGalleyErrors, -- * Performing actions updateLocalConversationWithLocalUser, @@ -32,6 +33,7 @@ module Galley.API.Action ensureConversationActionAllowed, addMembersToLocalConversation, notifyConversationAction, + notifyRemoteConversationAction, ConversationUpdate, ) where @@ -39,6 +41,7 @@ where import qualified Brig.Types.User as User import Control.Arrow import Control.Lens +import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Kind import Data.List.NonEmpty (nonEmpty) @@ -72,6 +75,8 @@ import Imports import Polysemy import Polysemy.Error import Polysemy.Input +import qualified Polysemy.TinyLog as P +import qualified System.Logger as Log import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Conversation.Protocol @@ -129,7 +134,6 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con BrigAccess, CodeStore, Error InvalidInput, - Error InvalidInput, Error NoChanges, ErrorS 'InvalidTargetAccess, ErrorS ('ActionDenied 'RemoveConversationMember), @@ -148,6 +152,63 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con HasConversationActionEffects 'ConversationReceiptModeUpdateTag r = Members '[ConversationStore, Error NoChanges] r +type family HasConversationActionGalleyErrors (tag :: ConversationActionTag) :: EffectRow where + HasConversationActionGalleyErrors 'ConversationJoinTag = + '[ ErrorS ('ActionDenied 'LeaveConversation), + ErrorS ('ActionDenied 'AddConversationMember), + ErrorS 'NotATeamMember, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'NotConnected, + ErrorS 'ConvAccessDenied, + ErrorS 'TooManyMembers, + ErrorS 'MissingLegalholdConsent + ] + HasConversationActionGalleyErrors 'ConversationLeaveTag = + '[ ErrorS ('ActionDenied 'LeaveConversation), + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound + ] + HasConversationActionGalleyErrors 'ConversationRemoveMembersTag = + '[ ErrorS ('ActionDenied 'RemoveConversationMember), + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound + ] + HasConversationActionGalleyErrors 'ConversationMemberUpdateTag = + '[ ErrorS ('ActionDenied 'ModifyOtherConversationMember), + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'ConvMemberNotFound + ] + HasConversationActionGalleyErrors 'ConversationDeleteTag = + '[ ErrorS ('ActionDenied 'DeleteConversation), + ErrorS 'NotATeamMember, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound + ] + HasConversationActionGalleyErrors 'ConversationRenameTag = + '[ ErrorS ('ActionDenied 'ModifyConversationName), + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound + ] + HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag = + '[ ErrorS ('ActionDenied 'ModifyConversationMessageTimer), + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound + ] + HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag = + '[ ErrorS ('ActionDenied 'ModifyConversationReceiptMode), + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound + ] + HasConversationActionGalleyErrors 'ConversationAccessDataTag = + '[ ErrorS ('ActionDenied 'RemoveConversationMember), + ErrorS ('ActionDenied 'ModifyConversationAccess), + ErrorS 'InvalidOperation, + ErrorS 'InvalidTargetAccess, + ErrorS 'ConvNotFound + ] + noChanges :: Member (Error NoChanges) r => Sem r a noChanges = throw NoChanges @@ -637,3 +698,51 @@ notifyConversationAction tag quid con lcnv targets action = do -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) $> e + +-- | Notify all local members about a remote conversation update that originated +-- from a local user +notifyRemoteConversationAction :: + Members + '[ FederatorAccess, + ExternalAccess, + GundeckAccess, + MemberStore, + Input (Local ()), + P.TinyLog + ] + r => + Remote ConversationUpdate -> + ConnId -> + Sem r Event +notifyRemoteConversationAction rconvUpdate con = do + let convUpdate = tUnqualified rconvUpdate + rconvId = qualifyAs rconvUpdate . cuConvId $ convUpdate + + let event = + case cuAction convUpdate of + SomeConversationAction tag action -> + conversationActionToEvent tag (cuTime convUpdate) (cuOrigUserId convUpdate) (qUntagged rconvId) action + + -- Note: we generally do not send notifications to users that are not part of + -- the conversation (from our point of view), to prevent spam from the remote + -- backend. + (presentUsers, allUsersArePresent) <- + E.selectRemoteMembers (cuAlreadyPresentUsers convUpdate) rconvId + loc <- qualifyLocal () + let localPresentUsers = qualifyAs loc presentUsers + + unless allUsersArePresent $ + P.warn $ + Log.field "conversation" (toByteString' . tUnqualified $ rconvId) + . Log.field "domain" (toByteString' (tDomain rconvUpdate)) + . Log.msg + ( "Attempt to send notification about conversation update \ + \to users not in the conversation" :: + ByteString + ) + + -- FUTUREWORK: Check if presentUsers contain bots when federated bots are + -- implemented. + let bots = [] + + pushConversationEvent (Just con) event localPresentUsers bots $> event diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index bf9999673c..0f39544d02 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -30,7 +30,7 @@ import Data.Map.Lens (toMapOf) import Data.Qualified import Data.Range (Range (fromRange)) import qualified Data.Set as Set -import Data.Singletons (sing) +import Data.Singletons (SingI (..), demote, sing) import qualified Data.Text.Lazy as LT import Data.Time.Clock import Galley.API.Action @@ -52,11 +52,12 @@ import Imports import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.Internal.Kind (Append) import qualified Polysemy.TinyLog as P import Servant (ServerT) import Servant.API import qualified System.Logger.Class as Log -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import Wire.API.Conversation.Role @@ -66,7 +67,9 @@ import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Common (EmptyResponse (..)) +import Wire.API.Federation.API.Galley (ConversationUpdateResponse) import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Error import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named import Wire.API.ServantProto @@ -74,6 +77,7 @@ import Wire.API.User.Client (userClientMap) type FederationAPI = "federation" :> FedApi 'Galley +-- | Convert a polysemy handler to an 'API' value. federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = Named @"on-conversation-created" onConversationCreated @@ -83,6 +87,7 @@ federationSitemap = :<|> Named @"on-message-sent" onMessageSent :<|> Named @"send-message" sendMessage :<|> Named @"on-user-deleted-conversations" onUserDeleted + :<|> Named @"update-conversation" updateConversation onConversationCreated :: Members @@ -250,6 +255,7 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do E.createMembersInRemoteConversation remoteConvId connectedList pure connected +-- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: Members '[ ConversationStore, @@ -417,3 +423,103 @@ onUserDeleted origDomain udcn = do botsAndMembers = convBotsAndMembers conv void $ notifyConversationAction (sing @'ConversationLeaveTag) untaggedDeletedUser Nothing lc botsAndMembers action pure EmptyResponse + +updateConversation :: + forall r. + ( Members + '[ BrigAccess, + CodeStore, + BotAccess, + FireAndForget, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + Error InternalError, + GundeckAccess, + Input Opts, + Input UTCTime, + LegalHoldStore, + MemberStore, + TeamStore, + ConversationStore, + Input (Local ()) + ] + r + ) => + -- | + Domain -> + -- | + F.ConversationUpdateRequest -> + Sem r ConversationUpdateResponse +updateConversation origDomain updateRequest = do + loc <- qualifyLocal () + let rusr = toRemoteUnsafe origDomain (F.curUser updateRequest) + lcnv = qualifyAs loc (F.curConvId updateRequest) + + mkResponse $ case F.curAction updateRequest of + SomeConversationAction tag action -> + case tag of + SConversationJoinTag -> + mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) $ + updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationLeaveTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationLeaveTag) + $ updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationRemoveMembersTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationRemoveMembersTag) + $ updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationMemberUpdateTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationMemberUpdateTag) + $ updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationDeleteTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationDeleteTag) + $ updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationRenameTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationRenameTag) + $ updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationMessageTimerUpdateTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag) + $ updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationReceiptModeUpdateTag -> + mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag) $ + updateLocalConversationWithRemoteUser tag lcnv rusr action + SConversationAccessDataTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) + $ updateLocalConversationWithRemoteUser tag lcnv rusr action + where + mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges + + toResponse (Left galleyErr) = F.ConversationUpdateResponseError galleyErr + toResponse (Right (Left NoChanges)) = F.ConversationUpdateResponseNoChanges + toResponse (Right (Right update)) = F.ConversationUpdateResponseUpdate update + +class ToGalleyRuntimeError (effs :: EffectRow) r where + mapToGalleyError :: + Member (Error GalleyError) r => + Sem (Append effs r) a -> + Sem r a + +instance ToGalleyRuntimeError '[] r where + mapToGalleyError = id + +instance + forall (err :: GalleyError) effs r. + ( ToGalleyRuntimeError effs r, + SingI err, + Member (Error GalleyError) (Append effs r) + ) => + ToGalleyRuntimeError (ErrorS err ': effs) r + where + mapToGalleyError act = + mapToGalleyError @effs @r $ + runError act >>= \case + Left _ -> throw (demote @err) + Right res -> pure res diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 7c999a46cb..07ba09609a 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -35,6 +35,7 @@ module Galley.API.Update updateConversationAccessUnqualified, updateConversationAccess, deleteLocalConversation, + updateRemoteConversation, -- * Managing Members addMembersUnqualified, @@ -75,9 +76,11 @@ import qualified Data.Map.Strict as Map import Data.Qualified import qualified Data.Set as Set import Data.Singletons +import qualified Data.Text as T import Data.Time import Galley.API.Action import Galley.API.Error +import Galley.API.Federation (onConversationUpdated) import Galley.API.Mapping import Galley.API.Message import qualified Galley.API.Query as Query @@ -111,6 +114,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation.Action import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley @@ -301,15 +305,19 @@ updateConversationAccessUnqualified lusr con cnv update = updateConversationReceiptMode :: Members - '[ ConversationStore, - Error FederationError, + '[ Error FederationError, ErrorS ('ActionDenied 'ModifyConversationReceiptMode), ErrorS 'ConvNotFound, ErrorS 'InvalidOperation, ExternalAccess, FederatorAccess, GundeckAccess, - Input UTCTime + BrigAccess, + ConversationStore, + MemberStore, + Input UTCTime, + Input (Local ()), + TinyLog ] r => Local UserId -> @@ -318,12 +326,69 @@ updateConversationReceiptMode :: ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) updateConversationReceiptMode lusr zcon qcnv update = - getUpdateResult $ - foldQualified - lusr - (\lcnv -> updateLocalConversationWithLocalUser @'ConversationReceiptModeUpdateTag lcnv lusr (Just zcon) update) - (\_ -> throw FederationNotImplemented) - qcnv + foldQualified + lusr + (\lcnv -> getUpdateResult $ updateLocalConversationWithLocalUser @'ConversationReceiptModeUpdateTag lcnv lusr (Just zcon) update) + (\rcnv -> updateRemoteConversation @'ConversationReceiptModeUpdateTag rcnv lusr zcon update) + qcnv + +updateRemoteConversation :: + forall tag r. + ( Members + '[ BrigAccess, + Error FederationError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + Input (Local ()), + MemberStore, + TinyLog + ] + r, + Members (HasConversationActionGalleyErrors tag) r, + RethrowErrors (HasConversationActionGalleyErrors tag) (Error NoChanges : r), + SingI tag + ) => + Remote ConvId -> + Local UserId -> + ConnId -> + ConversationAction tag -> + Sem r (UpdateResult Event) +updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do + let updateRequest = + ConversationUpdateRequest + { curUser = tUnqualified lusr, + curConvId = tUnqualified rcnv, + curAction = SomeConversationAction (sing @tag) action + } + response <- E.runFederated rcnv (fedClient @'Galley @"update-conversation" updateRequest) + convUpdate <- case response of + ConversationUpdateResponseNoChanges -> throw NoChanges + ConversationUpdateResponseError err' -> rethrowErrors @(HasConversationActionGalleyErrors tag) err' + ConversationUpdateResponseUpdate convUpdate -> pure convUpdate + + onConversationUpdated (tDomain rcnv) convUpdate + notifyRemoteConversationAction (qualifyAs rcnv convUpdate) conn + +class RethrowErrors (effs :: EffectRow) r where + rethrowErrors :: GalleyError -> Sem r a + +instance (Member (Error FederationError) r) => RethrowErrors '[] r where + rethrowErrors :: GalleyError -> Sem r a + rethrowErrors err' = throw (FederationUnexpectedError (T.pack . show $ err')) + +instance + ( SingI (e :: GalleyError), + Member (ErrorS e) r, + RethrowErrors effs r + ) => + RethrowErrors (ErrorS e ': effs) r + where + rethrowErrors :: GalleyError -> Sem r a + rethrowErrors err' = + if err' == demote @e + then throwS @e + else rethrowErrors @effs @r err' updateConversationReceiptModeUnqualified :: Members @@ -335,7 +400,11 @@ updateConversationReceiptModeUnqualified :: ExternalAccess, FederatorAccess, GundeckAccess, - Input UTCTime + BrigAccess, + MemberStore, + Input UTCTime, + Input (Local ()), + TinyLog ] r => Local UserId -> diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 8357c98121..9fa8bd709b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -204,6 +204,7 @@ tests s = test s "remote conversation member update (everything)" putRemoteConvMemberAllOk, test s "conversation receipt mode update" putReceiptModeOk, test s "conversation receipt mode update with remote members" putReceiptModeWithRemotesOk, + test s "remote conversation receipt mode update" putRemoteReceiptModeOk, test s "send typing indicators" postTypingIndicators, test s "leave connect conversation" leaveConnectConversation, test s "post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient, @@ -3443,6 +3444,88 @@ putReceiptModeOk = do assertEqual "modes should match" mode 0 _ -> assertFailure "Unexpected event data" +-- | Test setup +-- A (local) - alice: admin on remote conversation, adam: regular member of remote conversation +-- B (mocked) - owns the conversation +-- +-- The federator on A is also mocked. +-- +-- alice changes receipt remote via client api +-- assertion: A's federator is called correctly +-- assertion: backend A generates events for adam +-- and federator's response +putRemoteReceiptModeOk :: TestM () +putRemoteReceiptModeOk = do + c <- view tsCannon + qalice <- randomQualifiedUser + let alice = qUnqualified qalice + + -- create a remote conversation at bob with alice as admin + let remoteDomain = Domain "bobland.example.com" + qbob <- Qualified <$> randomId <*> pure remoteDomain + qconv <- Qualified <$> randomId <*> pure remoteDomain + connectWithRemoteUser alice qbob + fedGalleyClient <- view tsFedGalleyClient + now <- liftIO getCurrentTime + let cuAddAlice = + F.ConversationUpdate + { cuTime = now, + cuOrigUserId = qbob, + cuConvId = qUnqualified qconv, + cuAlreadyPresentUsers = [], + cuAction = + SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireAdmin) + } + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAlice + + -- add another user adam as member + qadam <- randomQualifiedUser + let adam = qUnqualified qadam + connectWithRemoteUser adam qbob + let cuAddAdam = + F.ConversationUpdate + { cuTime = now, + cuOrigUserId = qbob, + cuConvId = qUnqualified qconv, + cuAlreadyPresentUsers = [], + cuAction = + SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qadam) roleNameWireMember) + } + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAdam + + let newReceiptMode = ReceiptMode 42 + let action = ConversationReceiptModeUpdate newReceiptMode + let responseConvUpdate = + F.ConversationUpdate + { cuTime = now, + cuOrigUserId = qalice, + cuConvId = qUnqualified qconv, + cuAlreadyPresentUsers = [adam], + cuAction = + SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) action + } + let mockResponse = const (ConversationUpdateResponseUpdate responseConvUpdate) + + WS.bracketR c adam $ \wsAdam -> do + (res, federatedRequests) <- withTempMockFederator mockResponse $ do + putQualifiedReceiptMode alice qconv newReceiptMode + frTargetDomain r == remoteDomain && frRPC r == "update-conversation") federatedRequests + cFedReqBody <- assertRight $ parseFedRequest cFedReq + liftIO $ do + curUser cFedReqBody @?= alice + curConvId cFedReqBody @?= qUnqualified qconv + curAction cFedReqBody @?= SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) action + + WS.assertMatch_ (5 # Second) wsAdam $ \n -> do + liftIO $ wsAssertConvReceiptModeUpdate qconv qalice newReceiptMode n + putReceiptModeWithRemotesOk :: TestM () putReceiptModeWithRemotesOk = do c <- view tsCannon diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 165bb73816..8caf4f881d 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -38,6 +38,7 @@ module API.Federation where import API.Util import Bilge import Bilge.Assert +import Bilge.TestSession (liftSession) import Control.Lens hiding ((#)) import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as A @@ -104,7 +105,8 @@ tests s = test s "POST /federation/leave-conversation : Invalid type" leaveConversationInvalidType, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, - test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted + test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted, + test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin ] getConversationsAllFound :: TestM () @@ -1055,4 +1057,125 @@ onUserDeleted = do FedGalley.cuOrigUserId cDomainRPCReq @?= qUntagged bob FedGalley.cuConvId cDomainRPCReq @?= qUnqualified groupConvId FedGalley.cuAlreadyPresentUsers cDomainRPCReq @?= [qUnqualified carl] - FedGalley.cuAction cDomainRPCReq @?= (SomeConversationAction (sing @'ConversationLeaveTag) (pure $ qUntagged bob)) + FedGalley.cuAction cDomainRPCReq @?= SomeConversationAction (sing @'ConversationLeaveTag) (pure $ qUntagged bob) + +-- | We test only ReceiptMode update here +-- +-- A : local domain, owns the conversation +-- B : bob is an admin of the converation +-- C : charlie is a regular member of the conversation +updateConversationByRemoteAdmin :: TestM () +updateConversationByRemoteAdmin = do + c <- view tsCannon + (alice, qalice) <- randomUserTuple + + let bdomain = Domain "b.example.com" + cdomain = Domain "c.example.com" + qbob <- randomQualifiedId bdomain + qcharlie <- randomQualifiedId cdomain + mapM_ (connectWithRemoteUser alice) [qbob, qcharlie] + + let convName = "Test Conv" + WS.bracketR c alice $ \wsAlice -> do + (rsp, _federatedRequests) <- + withTempMockFederator (const ()) $ do + postConvQualified alice defNewProteusConv {newConvName = checked convName, newConvQualifiedUsers = [qbob, qcharlie]} + assertFailure ("Expected ConversationUpdateResponseUpdate but got " <> show err) + ConversationUpdateResponseNoChanges -> assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseNoChanges" + ConversationUpdateResponseUpdate up -> pure up + + liftIO $ do + cuOrigUserId cnvUpdate' @?= qbob + cuAlreadyPresentUsers cnvUpdate' @?= [qUnqualified qbob] + cuAction cnvUpdate' @?= action + + -- backend A generates a notification for alice + void $ + WS.awaitMatch (5 # Second) wsAlice $ \n -> do + liftIO $ wsAssertConvReceiptModeUpdate cnv qalice newReceiptMode n + + -- backend B does *not* get notified of the conversation update ony of bob's promotion + liftIO $ do + [(_fr, cUpdate)] <- mapM parseConvUpdate $ filter (\r -> frTargetDomain r == bdomain) federatedRequests + assertBool "Action is not a ConversationMemberUpdate" (isJust (getConvAction (sing @'ConversationMemberUpdateTag) (cuAction cUpdate))) + + -- conversation has been modified by action + updatedConv :: Conversation <- fmap responseJsonUnsafe $ getConvQualified alice cnv frTargetDomain r == cdomain) federatedRequests + + (_fr1, _cu1, _up1) <- assertOne $ mapMaybe (\(fr, up) -> getConvAction (sing @'ConversationMemberUpdateTag) (cuAction up) <&> (fr,up,)) dUpdates + + (_fr2, convUpdate, receiptModeUpdate) <- assertOne $ mapMaybe (\(fr, up) -> getConvAction (sing @'ConversationReceiptModeUpdateTag) (cuAction up) <&> (fr,up,)) dUpdates + + cruReceiptMode receiptModeUpdate @?= newReceiptMode + cuOrigUserId convUpdate @?= qbob + cuConvId convUpdate @?= qUnqualified cnv + cuAlreadyPresentUsers convUpdate @?= [qUnqualified qcharlie] + + WS.assertMatch_ (5 # Second) wsAlice $ \n -> do + wsAssertConvReceiptModeUpdate cnv qbob newReceiptMode n + where + _toOtherMember qid = OtherMember qid Nothing roleNameWireAdmin + _convView cnv usr = responseJsonUnsafeWithMsg "conversation" <$> getConv usr cnv + + parseConvUpdate :: FederatedRequest -> IO (FederatedRequest, ConversationUpdate) + parseConvUpdate rpc = do + frComponent rpc @?= Galley + frRPC rpc @?= "on-conversation-updated" + let convUpdate :: ConversationUpdate = fromRight (error $ "Could not parse ConversationUpdate from " <> show (frBody rpc)) $ A.eitherDecode (frBody rpc) + pure (rpc, convUpdate) + +getConvAction :: Sing tag -> SomeConversationAction -> Maybe (ConversationAction tag) +getConvAction tquery (SomeConversationAction tag action) = + case (tag, tquery) of + (SConversationJoinTag, SConversationJoinTag) -> Just action + (SConversationJoinTag, _) -> Nothing + (SConversationLeaveTag, SConversationLeaveTag) -> Just action + (SConversationLeaveTag, _) -> Nothing + (SConversationMemberUpdateTag, SConversationMemberUpdateTag) -> Just action + (SConversationMemberUpdateTag, _) -> Nothing + (SConversationDeleteTag, SConversationDeleteTag) -> Just action + (SConversationDeleteTag, _) -> Nothing + (SConversationRenameTag, SConversationRenameTag) -> Just action + (SConversationRenameTag, _) -> Nothing + (SConversationMessageTimerUpdateTag, SConversationMessageTimerUpdateTag) -> Just action + (SConversationMessageTimerUpdateTag, _) -> Nothing + (SConversationReceiptModeUpdateTag, SConversationReceiptModeUpdateTag) -> Just action + (SConversationReceiptModeUpdateTag, _) -> Nothing + (SConversationAccessDataTag, SConversationAccessDataTag) -> Just action + (SConversationAccessDataTag, _) -> Nothing + (SConversationRemoveMembersTag, SConversationRemoveMembersTag) -> Just action + (SConversationRemoveMembersTag, _) -> Nothing diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index bfab699f10..c65997d610 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -16,6 +14,8 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module API.Util where @@ -36,7 +36,9 @@ import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _String) import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy import qualified Data.CaseInsensitive as CI @@ -58,6 +60,7 @@ import qualified Data.ProtoLens as Protolens import Data.ProtocolBuffers (encodeMessage) import Data.Qualified import Data.Range +import qualified Data.Sequence as Seq import Data.Serialize (runPut) import qualified Data.Set as Set import Data.Singletons @@ -71,6 +74,7 @@ import qualified Data.UUID as UUID import Data.UUID.V4 import Federator.MockServer (FederatedRequest (..)) import qualified Federator.MockServer as Mock +import GHC.TypeLits import Galley.Intra.User (chunkify) import qualified Galley.Options as Opts import qualified Galley.Run as Run @@ -85,11 +89,19 @@ import Galley.Types.Teams.Intra import Galley.Types.UserList import Imports import Network.HTTP.Media.MediaType +import Network.HTTP.Media.RenderHeader (renderHeader) +import Network.HTTP.Types (http11, renderQuery) import qualified Network.HTTP.Types as HTTP import Network.Wai (Application, defaultRequest) import qualified Network.Wai as Wai import qualified Network.Wai.Test as Wai +import qualified Network.Wai.Test as WaiTest import Servant (Handler, HasServer, Server, ServerT, serve, (:<|>) (..)) +import Servant.Client (ClientError (FailureResponse)) +import qualified Servant.Client as Servant +import Servant.Client.Core (RunClient (throwClientError)) +import qualified Servant.Client.Core as Servant +import qualified Servant.Client.Core.Request as ServantRequest import System.Exit import System.Process import System.Random @@ -2767,3 +2779,99 @@ decodeMLSError :: ParseMLS a => ByteString -> IO a decodeMLSError s = case decodeMLS' s of Left e -> assertFailure ("Could not parse MLS object: " <> Text.unpack e) Right x -> pure x + +wsAssertConvReceiptModeUpdate :: Qualified ConvId -> Qualified UserId -> ReceiptMode -> Notification -> IO () +wsAssertConvReceiptModeUpdate conv usr new n = do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= conv + evtType e @?= ConvReceiptModeUpdate + evtFrom e @?= usr + evtData e @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate new) + +newtype WaiTestFedClient a = WaiTestFedClient {unWaiTestFedClient :: ReaderT Domain WaiTest.Session a} + deriving (Functor, Applicative, Monad, MonadIO) + +instance Servant.RunClient WaiTestFedClient where + runRequestAcceptStatus expectedStatuses servantRequest = WaiTestFedClient $ do + domain <- ask + let req' = fromServantRequest domain servantRequest + res <- lift $ WaiTest.srequest req' + let servantResponse = toServantResponse res + let status = Servant.responseStatusCode servantResponse + let statusIsSuccess = + case expectedStatuses of + Nothing -> HTTP.statusIsSuccessful status + Just ex -> status `elem` ex + unless statusIsSuccess $ + unWaiTestFedClient $ throwClientError (FailureResponse (bimap (const ()) (\x -> (Servant.BaseUrl Servant.Http "" 80 "", cs (toLazyByteString x))) servantRequest) servantResponse) + pure servantResponse + throwClientError = liftIO . throw + +fromServantRequest :: Domain -> Servant.Request -> WaiTest.SRequest +fromServantRequest domain r = + let pathBS = "/federation" <> Data.String.Conversions.cs (toLazyByteString (Servant.requestPath r)) + bodyBS = case Servant.requestBody r of + Nothing -> "" + Just (bdy, _) -> case bdy of + Servant.RequestBodyLBS lbs -> Data.String.Conversions.cs lbs + Servant.RequestBodyBS bs -> bs + Servant.RequestBodySource _ -> error "fromServantRequest: not implemented for RequestBodySource" + + -- Content-Type and Accept are specified by requestBody and requestAccept + headers = + filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ + toList $ Servant.requestHeaders r + acceptHdr + | null hs = Nothing + | otherwise = Just ("Accept", renderHeader hs) + where + hs = toList $ ServantRequest.requestAccept r + contentTypeHdr = case ServantRequest.requestBody r of + Nothing -> Nothing + Just (_', typ) -> Just (HTTP.hContentType, renderHeader typ) + req = + Wai.defaultRequest + { Wai.requestMethod = Servant.requestMethod r, + Wai.rawPathInfo = pathBS, + Wai.rawQueryString = renderQuery True (toList (Servant.requestQueryString r)), + Wai.requestHeaders = + -- Inspired by 'Servant.Client.Internal.HttpClient.defaultMakeClientRequest', + -- the Servant function that maps @Request@ to @Client.Request@. + -- This solution is a bit sophisticated due to two constraints: + -- - Accept header may contain a list of accepted media types. + -- - Accept and Content-Type headers should only appear once in the result. + maybeToList acceptHdr + <> maybeToList contentTypeHdr + <> headers + <> [(originDomainHeaderName, Text.encodeUtf8 (domainText domain))], + Wai.isSecure = True, + Wai.pathInfo = filter (not . Text.null) (map Data.String.Conversions.cs (C8.split '/' pathBS)), + Wai.queryString = toList (Servant.requestQueryString r) + } + in WaiTest.SRequest req (cs bodyBS) + +toServantResponse :: WaiTest.SResponse -> Servant.Response +toServantResponse res = + Servant.Response + { Servant.responseStatusCode = WaiTest.simpleStatus res, + Servant.responseHeaders = Seq.fromList (WaiTest.simpleHeaders res), + Servant.responseBody = WaiTest.simpleBody res, + Servant.responseHttpVersion = http11 + } + +createWaiTestFedClient :: + forall (name :: Symbol) comp api. + ( HasFedEndpoint comp api name, + Servant.HasClient WaiTestFedClient api + ) => + Servant.Client WaiTestFedClient api +createWaiTestFedClient = + Servant.clientIn (Proxy @api) (Proxy @WaiTestFedClient) + +runWaiTestFedClient :: + Domain -> + WaiTestFedClient a -> + WaiTest.Session a +runWaiTestFedClient domain action = + runReaderT (unWaiTestFedClient action) domain