diff --git a/changelog.d/1-api-changes/fs-926-add-global-team-conv b/changelog.d/1-api-changes/fs-926-add-global-team-conv new file mode 100644 index 0000000000..85996cd9ec --- /dev/null +++ b/changelog.d/1-api-changes/fs-926-add-global-team-conv @@ -0,0 +1 @@ +Added global conversation type and GET endpoint (`GET /teams/:tid/conversations/global`). diff --git a/libs/bilge/src/Bilge/Assert.hs b/libs/bilge/src/Bilge/Assert.hs index 2a584e5b6d..512aa0f925 100644 --- a/libs/bilge/src/Bilge/Assert.hs +++ b/libs/bilge/src/Bilge/Assert.hs @@ -26,6 +26,7 @@ module Bilge.Assert (===), (=/=), (=~=), + (=/~=), assertResponse, assertTrue, assertTrue_, @@ -141,6 +142,15 @@ f =/= g = Assertions $ tell [\r -> test " === " (/=) (f r) (g r)] Assertions () f =~= g = Assertions $ tell [\r -> test " not in " contains (f r) (g r)] +-- | Tests the assertion that the left-hand side is **not** contained in the right-hand side. +-- If it is, actual values will be printed. +(=/~=) :: + (HasCallStack, Show a, Contains a) => + (Response (Maybe Lazy.ByteString) -> a) -> + (Response (Maybe Lazy.ByteString) -> a) -> + Assertions () +f =/~= g = Assertions $ tell [\r -> test " in " ((not .) . contains) (f r) (g r)] + -- | Most generic assertion on a request. If the test function evaluates to -- @(Just msg)@ then the assertion fails with the error message @msg@. assertResponse :: HasCallStack => (Response (Maybe Lazy.ByteString) -> Maybe String) -> Assertions () diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index e55df61782..283c6a0a85 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -25,6 +25,7 @@ module Wire.API.Conversation ConversationMetadata (..), defConversationMetadata, Conversation (..), + conversationMetadataObjectSchema, cnvType, cnvCreator, cnvAccess, @@ -100,7 +101,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS import Data.Id -import Data.List.Extra (disjointOrd) +import Data.List.Extra (disjointOrd, enumerate) import Data.List.NonEmpty (NonEmpty) import Data.List1 import Data.Misc @@ -436,6 +437,10 @@ data Access LinkAccess | -- | User can join knowing [changeable/revokable] code CodeAccess + | -- | In MLS the user can join the global team conversation with their + -- | clients via an external commit, thereby inviting their own clients to + -- | join. + SelfInviteAccess deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) deriving (Arbitrary) via (GenericUniform Access) deriving (ToJSON, FromJSON, S.ToSchema) via Schema Access @@ -448,7 +453,8 @@ instance ToSchema Access where [ element "private" PrivateAccess, element "invite" InviteAccess, element "link" LinkAccess, - element "code" CodeAccess + element "code" CodeAccess, + element "self_invite" SelfInviteAccess ] typeAccess :: Doc.DataType @@ -496,6 +502,7 @@ defRole = activatedAccessRole maybeRole :: ConvType -> Maybe (Set AccessRoleV2) -> Set AccessRoleV2 maybeRole SelfConv _ = privateAccessRole +maybeRole GlobalTeamConv _ = teamAccessRole maybeRole ConnectConv _ = privateAccessRole maybeRole One2OneConv _ = privateAccessRole maybeRole RegularConv Nothing = defRole @@ -578,7 +585,8 @@ data ConvType | SelfConv | One2OneConv | ConnectConv - deriving stock (Eq, Show, Generic) + | GlobalTeamConv + deriving stock (Eq, Show, Generic, Enum, Bounded) deriving (Arbitrary) via (GenericUniform ConvType) deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConvType @@ -589,11 +597,12 @@ instance ToSchema ConvType where [ element 0 RegularConv, element 1 SelfConv, element 2 One2OneConv, - element 3 ConnectConv + element 3 ConnectConv, + element 4 GlobalTeamConv ] typeConversationType :: Doc.DataType -typeConversationType = Doc.int32 $ Doc.enum [0, 1, 2, 3] +typeConversationType = Doc.int32 $ Doc.enum $ fromIntegral . fromEnum <$> enumerate @ConvType -- | Define whether receipts should be sent in the given conversation -- This datatype is defined as an int32 but the Backend does not diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index 2d92ec4365..815903cb3e 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -53,6 +53,7 @@ import Wire.Arbitrary (Arbitrary (..)) -- individual effects per conversation action. See 'HasConversationActionEffects'. type family ConversationAction (tag :: ConversationActionTag) :: * where ConversationAction 'ConversationJoinTag = ConversationJoin + ConversationAction 'ConversationSelfInviteTag = ConvId ConversationAction 'ConversationLeaveTag = () ConversationAction 'ConversationMemberUpdateTag = ConversationMemberUpdate ConversationAction 'ConversationDeleteTag = () @@ -103,6 +104,7 @@ conversationActionSchema SConversationRenameTag = schema conversationActionSchema SConversationMessageTimerUpdateTag = schema conversationActionSchema SConversationReceiptModeUpdateTag = schema conversationActionSchema SConversationAccessDataTag = schema +conversationActionSchema SConversationSelfInviteTag = schema instance FromJSON SomeConversationAction where parseJSON = A.withObject "SomeConversationAction" $ \ob -> do @@ -150,6 +152,9 @@ conversationActionToEvent tag now quid qcnv action = SConversationJoinTag -> let ConversationJoin newMembers role = action in EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers)) + SConversationSelfInviteTag -> + -- this event will not be sent anyway so this is a dummy event + EdMembersJoin $ SimpleMembers [] SConversationLeaveTag -> EdMembersLeave (QualifiedUserIdList [quid]) SConversationRemoveMembersTag -> diff --git a/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs b/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs index 3445e3794f..3b0c782c37 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs @@ -30,6 +30,7 @@ import Wire.Arbitrary (Arbitrary (..)) data ConversationActionTag = ConversationJoinTag + | ConversationSelfInviteTag | ConversationLeaveTag | ConversationRemoveMembersTag | ConversationMemberUpdateTag @@ -48,6 +49,7 @@ instance ToSchema ConversationActionTag where enum @Text "ConversationActionTag" $ mconcat [ element "ConversationJoinTag" ConversationJoinTag, + element "ConversationSelfInviteTag" ConversationSelfInviteTag, element "ConversationLeaveTag" ConversationLeaveTag, element "ConversationRemoveMembersTag" ConversationRemoveMembersTag, element "ConversationMemberUpdateTag" ConversationMemberUpdateTag, diff --git a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs index 30ca0b6591..d580e5be88 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs @@ -28,6 +28,7 @@ module Wire.API.Conversation.Protocol _ProtocolMLS, _ProtocolProteus, protocolSchema, + mlsDataSchema, ConversationMLSData (..), ) where diff --git a/libs/wire-api/src/Wire/API/Conversation/Role.hs b/libs/wire-api/src/Wire/API/Conversation/Role.hs index e215b72db8..1878b99b65 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Role.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Role.hs @@ -36,6 +36,7 @@ module Wire.API.Conversation.Role wireConvRoleNames, roleNameWireAdmin, roleNameWireMember, + roleToRoleName, -- * Action Action (..), diff --git a/libs/wire-api/src/Wire/API/MLS/GlobalTeamConversation.hs b/libs/wire-api/src/Wire/API/MLS/GlobalTeamConversation.hs new file mode 100644 index 0000000000..f9f1096860 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/GlobalTeamConversation.hs @@ -0,0 +1,63 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.GlobalTeamConversation where + +import Control.Lens ((?~)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Id +import Data.Qualified +import Data.Schema +import qualified Data.Swagger as S +import Imports +import Wire.API.Conversation hiding (Conversation) +import Wire.API.Conversation.Protocol +import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) + +-- | Public-facing global team conversation. +-- Membership is implicit. Every member of a team is part of it. +-- Protocol is also implicit: it's always MLS. +data GlobalTeamConversation = GlobalTeamConversation + { gtcId :: Qualified ConvId, + gtcMlsMetadata :: ConversationMLSData, + gtcCreator :: Maybe UserId, + gtcAccess :: [Access], + gtcName :: Text, + gtcTeam :: TeamId + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform GlobalTeamConversation) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema GlobalTeamConversation + +instance ToSchema GlobalTeamConversation where + schema = + objectWithDocModifier + "GlobalTeamConversation" + (description ?~ "The global team conversation object as returned from the server") + $ GlobalTeamConversation + <$> gtcId .= field "qualified_id" schema + <*> gtcMlsMetadata .= mlsDataSchema + <*> gtcCreator + .= maybe_ + ( optFieldWithDocModifier + "creator" + (description ?~ "The creator's user ID") + schema + ) + <*> gtcAccess .= field "access" (array schema) + <*> gtcName .= field "name" schema + <*> gtcTeam .= field "team" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index 7e945ea4c5..a5731fc412 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -29,6 +29,7 @@ import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation +import Wire.API.MLS.GlobalTeamConversation import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Servant import Wire.API.Routes.MultiVerb @@ -114,6 +115,18 @@ type ConversationAPI = :> QualifiedCapture "cnv" ConvId :> Get '[Servant.JSON] Conversation ) + :<|> Named + "get-global-team-conversation" + ( Summary "Get the global conversation for a given team ID" + :> CanThrow 'ConvNotFound + :> CanThrow 'NotATeamMember + :> ZLocalUser + :> "teams" + :> Capture "tid" TeamId + :> "conversations" + :> "global" + :> Get '[Servant.JSON] GlobalTeamConversation + ) :<|> Named "get-conversation-roles" ( Summary "Get existing roles available for the given conversation" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs index 0a81f55c27..4a8f3924f0 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs @@ -34,7 +34,7 @@ type TeamAPI = "create-non-binding-team" ( Summary "Create a new non binding team" -- FUTUREWORK: deprecated in https://github.com/wireapp/wire-server/pull/2607 - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow 'NotConnected :> CanThrow 'UserBindingExists diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 75e296c708..05a66ba54c 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -48,6 +48,7 @@ library Wire.API.MLS.Credential Wire.API.MLS.Epoch Wire.API.MLS.Extension + Wire.API.MLS.GlobalTeamConversation Wire.API.MLS.Group Wire.API.MLS.GroupInfoBundle Wire.API.MLS.KeyPackage diff --git a/nix/pkgs/mls-test-cli/default.nix b/nix/pkgs/mls-test-cli/default.nix index 7d7d696113..b49f61ceaa 100644 --- a/nix/pkgs/mls-test-cli/default.nix +++ b/nix/pkgs/mls-test-cli/default.nix @@ -15,8 +15,8 @@ rustPlatform.buildRustPackage rec { src = fetchFromGitHub { owner = "wireapp"; repo = "mls-test-cli"; - sha256 = "sha256-/XQ/9oQTPkRqgMzDGRm+Oh9jgkdeDM1vRJ6/wEf2+bY="; - rev = "c6f80be2839ac1ed2894e96044541d1c3cf6ecdf"; + sha256 = "sha256-FjgAcYdUr/ZWdQxbck2UEG6NEEQLuz0S4a55hrAxUs4="; + rev = "82fc148964ef5baa92a90d086fdc61adaa2b5dbf"; }; doCheck = false; cargoSha256 = "sha256-AlZrxa7f5JwxxrzFBgeFSaYU6QttsUpfLYfq1HzsdbE="; diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 986ea5725f..bdba711649 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -43,6 +43,9 @@ x3 = limitRetries 3 <> exponentialBackoff 100000 zUser :: UserId -> Request -> Request zUser = header "Z-User" . toByteString' +zClient :: ClientId -> Request -> Request +zClient = header "Z-Client" . toByteString' + remote :: ByteString -> Msg -> Msg remote = field "remote" diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 1449ce29c5..aa05c55d7d 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1328,7 +1328,19 @@ createConvWithAccessRoles ars g u us = . contentJson . body (RequestBodyLBS (encode conv)) where - conv = NewConv us [] Nothing Set.empty ars Nothing Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing + conv = + NewConv + us + [] + Nothing + Set.empty + ars + Nothing + Nothing + Nothing + roleNameWireAdmin + ProtocolProteusTag + Nothing postMessage :: Galley -> diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index bc55820c78..36c273f625 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -217,7 +217,18 @@ createTeamConv :: HasCallStack => Galley -> TeamId -> UserId -> [UserId] -> Mayb createTeamConv g tid u us mtimer = do let tinfo = Just $ ConvTeamInfo tid let conv = - NewConv us [] Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin ProtocolProteusTag Nothing + NewConv + us + [] + Nothing + (Set.fromList []) + Nothing + tinfo + mtimer + Nothing + roleNameWireAdmin + ProtocolProteusTag + Nothing r <- post ( g diff --git a/services/brig/test/integration/API/TeamUserSearch.hs b/services/brig/test/integration/API/TeamUserSearch.hs index 68c0f00768..26159afdcd 100644 --- a/services/brig/test/integration/API/TeamUserSearch.hs +++ b/services/brig/test/integration/API/TeamUserSearch.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -24,16 +22,13 @@ import API.Team.Util (createPopulatedBindingTeamWithNamesAndHandles) import API.User.Util (activateEmail, initiateEmailUpdateNoSend) import Bilge (Manager, MonadHttp) import qualified Brig.Options as Opt -import Brig.User.Search.TeamUserSearch (TeamUserSearchSortBy (..), TeamUserSearchSortOrder (..)) import Control.Monad.Catch (MonadCatch) import Control.Retry () -import Data.ByteString.Conversion (ToByteString (..), toByteString) +import Data.ByteString.Conversion (toByteString) import Data.Handle (fromHandle) import Data.Id (TeamId, UserId) -import qualified Data.Map.Strict as M import Data.String.Conversions (cs) import Imports -import System.Random import System.Random.Shuffle (shuffleM) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual) diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index dbc08acb71..5c7e1552cb 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -1,7 +1,6 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -- This file is part of the Wire Server implementation. -- @@ -23,47 +22,19 @@ module Federation.Util where import Bilge -import Bilge.Assert ((!!!), (. -- for SES notifications -{-# OPTIONS_GHC -fno-warn-orphans -Wno-deprecations #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Util where diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index 084907c6eb..1a7d33bce1 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -1,5 +1,5 @@ {-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- This file is part of the Wire Server implementation. -- @@ -20,58 +20,22 @@ module Federator.InternalServer where -import Control.Exception (bracketOnError) -import qualified Control.Exception as E -import Control.Lens (view) import Data.Binary.Builder import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LBS -import Data.Default -import Data.Domain (domainText) -import Data.Either.Validation (Validation (..)) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.X509.CertificateStore -import Federator.App (runAppT) -import Federator.Discovery (DiscoverFederator, DiscoveryFailure (DiscoveryFailureDNSError, DiscoveryFailureSrvNotAvailable), runFederatorDiscovery) -import Federator.Env (Env, TLSSettings, applog, caStore, dnsResolver, runSettings, tls) +import Federator.Env (Env) import Federator.Error.ServerError import Federator.Options (RunSettings) import Federator.Remote import Federator.Response import Federator.Validation -import Foreign (mallocBytes) -import Foreign.Marshal (free) import Imports -import Network.HPACK (BufferSize) -import Network.HTTP.Client.Internal (openSocketConnection) -import Network.HTTP.Client.OpenSSL (withOpenSSL) import qualified Network.HTTP.Types as HTTP -import qualified Network.HTTP2.Client as HTTP2 -import Network.Socket (Socket) -import qualified Network.Socket as NS -import Network.TLS -import qualified Network.TLS as TLS -import qualified Network.TLS.Extra.Cipher as TLS import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp import Polysemy import Polysemy.Error -import qualified Polysemy.Error as Polysemy -import Polysemy.IO (embedToMonadIO) import Polysemy.Input -import qualified Polysemy.Input as Polysemy -import qualified Polysemy.Resource as Polysemy -import Polysemy.TinyLog (TinyLog) -import qualified Polysemy.TinyLog as Log -import Servant.Client.Core -import qualified System.TimeManager as T -import qualified System.X509 as TLS import Wire.API.Federation.Component -import Wire.Network.DNS.Effect (DNSLookup) -import qualified Wire.Network.DNS.Effect as Lookup -import Wire.Network.DNS.SRV (SrvTarget (..)) data RequestData = RequestData { rdTargetDomain :: Text, diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index dcae8353e8..2acdd7858c 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -52,6 +52,7 @@ import Data.Singletons import Data.Time.Clock import Galley.API.Error import Galley.API.MLS.Removal +import Galley.API.MLS.Util (globalTeamConvToConversation) import Galley.API.Util import Galley.App import Galley.Data.Conversation @@ -89,6 +90,7 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API (Component (Galley), fedClient) import Wire.API.Federation.API.Galley import Wire.API.Federation.Error +import Wire.API.MLS.GlobalTeamConversation import Wire.API.Team.LegalHold import Wire.API.Team.Member import qualified Wire.API.User as User @@ -96,6 +98,11 @@ import qualified Wire.API.User as User data NoChanges = NoChanges type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Constraint where + HasConversationActionEffects 'ConversationSelfInviteTag r = + Members + '[ ErrorS 'InvalidOperation + ] + r HasConversationActionEffects 'ConversationJoinTag r = Members '[ BrigAccess, @@ -130,6 +137,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con '[ MemberStore, Error InternalError, Error NoChanges, + ErrorS 'InvalidOperation, ExternalAccess, FederatorAccess, GundeckAccess, @@ -157,6 +165,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Error InvalidInput, Error NoChanges, ErrorS 'InvalidTargetAccess, + ErrorS 'InvalidOperation, ErrorS ('ActionDenied 'RemoveConversationMember), ExternalAccess, FederatorAccess, @@ -270,6 +279,13 @@ ensureAllowed tag loc action conv origUser = do -- not a team conv, so one of the other access roles has to allow this. when (Set.null $ cupAccessRoles action Set.\\ Set.fromList [TeamMemberAccessRole]) $ throwS @'InvalidTargetAccess + SConversationSelfInviteTag -> + unless + (convType conv == GlobalTeamConv) + $ throwS @'InvalidOperation + SConversationLeaveTag -> + when (convType conv == GlobalTeamConv) $ + throwS @'InvalidOperation _ -> pure () -- | Returns additional members that resulted from the action (e.g. ConversationJoin) @@ -342,6 +358,8 @@ performAction tag origUser lconv action = do SConversationAccessDataTag -> do (bm, act) <- performConversationAccessData origUser lconv action pure (bm, act) + SConversationSelfInviteTag -> + pure (mempty, action) performConversationJoin :: (HasConversationActionEffects 'ConversationJoinTag r) => @@ -579,7 +597,17 @@ updateLocalConversation lcnv qusr con action = do let tag = sing @tag -- retrieve conversation - conv <- getConversationWithError lcnv + conv <- do + -- Check if global or not, if global, map it to conversation + E.getGlobalTeamConversationById lcnv >>= \case + Just gtc -> + let c = gtcCreator gtc + in case c of + Nothing -> + throwS @'ConvNotFound + Just creator -> + pure $ globalTeamConvToConversation gtc creator mempty + Nothing -> getConversationWithError lcnv -- check that the action does not bypass the underlying protocol unless (protocolValidAction (convProtocol conv) (fromSing tag)) $ @@ -618,7 +646,10 @@ updateLocalConversationUnchecked lconv qusr con action = do conv = tUnqualified lconv -- retrieve member - self <- noteS @'ConvNotFound $ getConvMember lconv conv qusr + self <- + if (cnvmType . convMetadata . tUnqualified $ lconv) == GlobalTeamConv + then pure $ Left $ localMemberFromUser (qUnqualified qusr) + else noteS @'ConvNotFound $ getConvMember lconv conv qusr -- perform checks ensureConversationActionAllowed (sing @tag) lcnv action conv self @@ -638,6 +669,23 @@ updateLocalConversationUnchecked lconv qusr con action = do -- -------------------------------------------------------------------------------- -- -- Utilities +localMemberFromUser :: UserId -> LocalMember +localMemberFromUser uid = + LocalMember + { lmId = uid, + lmStatus = + MemberStatus + { msOtrMutedStatus = Nothing, + msOtrMutedRef = Nothing, + msOtrArchived = False, + msOtrArchivedRef = Nothing, + msHidden = False, + msHiddenRef = Nothing + }, + lmService = Nothing, + lmConvRoleName = roleToRoleName convRoleWireMember + } + ensureConversationActionAllowed :: forall tag mem x r. ( IsConvMember mem, @@ -658,7 +706,7 @@ ensureConversationActionAllowed tag loc action conv self = do -- general action check ensureActionAllowed (sConversationActionPermission tag) self - -- check if it is a group conversation (except for rename actions) + -- check if it is a group or global conversation (except for rename actions) when (fromSing tag /= ConversationRenameTag) $ ensureGroupConversation conv @@ -789,16 +837,19 @@ notifyRemoteConversationAction loc rconvUpdate con = do -- leave, but then sends notifications as if the user was removed by someone -- else. kickMember :: - ( Member (Error InternalError) r, - Member ExternalAccess r, - Member FederatorAccess r, - Member GundeckAccess r, - Member ProposalStore r, - Member (Input UTCTime) r, - Member (Input Env) r, - Member MemberStore r, - Member TinyLog r - ) => + Members + '[ Error InternalError, + ErrorS 'InvalidOperation, + ExternalAccess, + FederatorAccess, + GundeckAccess, + ProposalStore, + Input UTCTime, + Input Env, + MemberStore, + TinyLog + ] + r => Qualified UserId -> Local Conversation -> BotsAndMembers -> diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 06f461f911..1ce9c5f337 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -279,7 +279,7 @@ onConversationUpdated requestingDomain cu = do SConversationMessageTimerUpdateTag -> pure (Just sca, []) SConversationReceiptModeUpdateTag -> pure (Just sca, []) SConversationAccessDataTag -> pure (Just sca, []) - + SConversationSelfInviteTag -> pure (Nothing, []) unless allUsersArePresent $ P.warn $ Log.field "conversation" (toByteString' (F.cuConvId cu)) @@ -495,6 +495,8 @@ onUserDeleted origDomain udcn = do Public.ConnectConv -> pure () -- The self conv cannot be on a remote backend. Public.SelfConv -> pure () + -- The global team conv cannot be on a remote backend. + Public.GlobalTeamConv -> pure () Public.RegularConv -> do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (qUntagged deletedUser) @@ -588,6 +590,8 @@ updateConversation origDomain updateRequest = do @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) . fmap lcuUpdate $ updateLocalConversation @'ConversationAccessDataTag lcnv (qUntagged rusr) Nothing action + SConversationSelfInviteTag -> + throw InvalidOperation where mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index b2e55a7bce..87e9de0345 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -303,7 +303,7 @@ type ITeamsAPIBase = Named "get-team-internal" (CanThrow 'TeamNotFound :> Get '[Servant.JSON] TeamData) :<|> Named "create-binding-team" - ( ZUser + ( ZLocalUser :> ReqBody '[Servant.JSON] BindingNewTeam :> MultiVerb1 'PUT @@ -691,28 +691,38 @@ rmUser lusr conn = do let qUser = qUntagged lusr cc <- getConversations ids now <- input - pp <- for cc $ \c -> case Data.convType c of - SelfConv -> pure Nothing - One2OneConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing - ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing - RegularConv - | tUnqualified lusr `isMember` Data.convLocalMembers c -> do + let deleteIfNeeded c = do + when (tUnqualified lusr `isMember` Data.convLocalMembers c) $ do runError (removeUser (qualifyAs lusr c) (qUntagged lusr)) >>= \case Left e -> P.err $ Log.msg ("failed to send remove proposal: " <> internalErrorDescription e) Right _ -> pure () deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) - let e = - Event - (qUntagged (qualifyAs lusr (Data.convId c))) - (qUntagged lusr) - now - (EdMembersLeave (QualifiedUserIdList [qUser])) for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) - pure $ - Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) - <&> set Intra.pushConn conn - . set Intra.pushRoute Intra.RouteDirect - | otherwise -> pure Nothing + let e = + Event + (qUntagged (qualifyAs lusr (Data.convId c))) + (qUntagged lusr) + now + (EdMembersLeave (QualifiedUserIdList [qUser])) + pure $ + Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) + <&> set Intra.pushConn conn + . set Intra.pushRoute Intra.RouteDirect + + deleteClientsFromGlobal c = do + runError (removeUser (qualifyAs lusr c) (qUntagged lusr)) >>= \case + Left e -> P.err $ Log.msg ("failed to send remove proposal: " <> internalErrorDescription e) + Right _ -> pure () + deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) + for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) + pure Nothing + + pp <- for cc $ \c -> case Data.convType c of + SelfConv -> pure Nothing + One2OneConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing + ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing + RegularConv -> deleteIfNeeded c + GlobalTeamConv -> deleteClientsFromGlobal c for_ (maybeList1 (catMaybes pp)) diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 6e2a04aaf2..d3d259c880 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -495,7 +495,6 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of Right ApplicationMessageTag -> pure mempty Left _ -> throwS @'MLSUnsupportedMessage - -- forward message propagateMessage qusr lconv cm con (rmRaw smsg) pure events @@ -556,7 +555,6 @@ type HasProposalEffects r = Member MemberStore r, Member ProposalStore r, Member TeamStore r, - Member TeamStore r, Member TinyLog r ) @@ -842,6 +840,24 @@ processInternalCommit qusr senderClient con lconv cm epoch groupId action sender "Unexpected creator client set in a self-conversation" -- this is a newly created conversation, and it should contain exactly one -- client (the creator) + + (Left _, GlobalTeamConv, []) -> do + creatorClient <- noteS @'MLSMissingSenderClient senderClient + creatorRef <- + maybe + (pure senderRef) + ( note (mlsProtocolError "Could not compute key package ref") + . kpRef' + . upLeaf + ) + $ cPath commit + addMLSClients + (convId <$> lconv) + qusr + (Set.singleton (creatorClient, creatorRef)) + (Left _, GlobalTeamConv, _) -> + throw . InternalErrorWithDescription $ + "Unexpected creator client set in a global teamconversation" (Left lm, _, [(qu, (creatorClient, _))]) | qu == qUntagged (qualifyAs lconv (lmId lm)) -> do -- use update path as sender reference and if not existing fall back to sender diff --git a/services/galley/src/Galley/API/MLS/Util.hs b/services/galley/src/Galley/API/MLS/Util.hs index 1095e1ef62..0fefb44af1 100644 --- a/services/galley/src/Galley/API/MLS/Util.hs +++ b/services/galley/src/Galley/API/MLS/Util.hs @@ -20,25 +20,52 @@ module Galley.API.MLS.Util where import Control.Comonad import Data.Id import Data.Qualified -import Galley.Data.Conversation.Types hiding (Conversation) +import Galley.Data.Conversation import qualified Galley.Data.Conversation.Types as Data import Galley.Effects import Galley.Effects.ConversationStore import Galley.Effects.MemberStore import Galley.Effects.ProposalStore +import Galley.Types.Conversations.Members import Imports import Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as TinyLog import qualified System.Logger as Log +import Wire.API.Conversation hiding (Conversation) +import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.MLS.Epoch -import Wire.API.MLS.Group +import Wire.API.MLS.GlobalTeamConversation import Wire.API.MLS.KeyPackage import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation +globalTeamConvToConversation :: + GlobalTeamConversation -> + UserId -> + [LocalMember] -> + Conversation +globalTeamConvToConversation gtc creator lMembers = + Conversation + { convId = qUnqualified $ gtcId gtc, + convLocalMembers = lMembers, + convRemoteMembers = mempty, + convDeleted = False, + convMetadata = + ConversationMetadata + { cnvmType = GlobalTeamConv, + cnvmCreator = creator, + cnvmAccess = gtcAccess gtc, + cnvmAccessRoles = mempty, + cnvmName = Just (gtcName gtc), + cnvmTeam = Just (gtcTeam gtc), + cnvmMessageTimer = Nothing, + cnvmReceiptMode = Nothing + }, + convProtocol = ProtocolMLS (gtcMlsMetadata gtc) + } + getLocalConvForUser :: Members '[ ErrorS 'ConvNotFound, @@ -50,10 +77,29 @@ getLocalConvForUser :: Local ConvId -> Sem r Data.Conversation getLocalConvForUser qusr lcnv = do - conv <- getConversation (tUnqualified lcnv) >>= noteS @'ConvNotFound + gtc <- getGlobalTeamConversationById lcnv + conv <- case gtc of + Just conv -> do + let creator = gtcCreator conv + localMembers <- getLocalMembers (qUnqualified . gtcId $ conv) + + -- no creator means the conversation has been setup on backend but not on MLS. + case creator of + Nothing -> do + setGlobalTeamConversationCreator conv (qUnqualified qusr) + pure $ globalTeamConvToConversation conv (qUnqualified qusr) localMembers + Just creator' -> + pure $ globalTeamConvToConversation conv creator' localMembers + Nothing -> do + getConversation (tUnqualified lcnv) >>= noteS @'ConvNotFound -- check that sender is part of conversation - isMember' <- foldQualified lcnv (fmap isJust . getLocalMember (convId conv) . tUnqualified) (fmap isJust . getRemoteMember (convId conv)) qusr + isMember' <- + foldQualified + lcnv + (fmap isJust . getLocalMember (convId conv) . tUnqualified) + (fmap isJust . getRemoteMember (convId conv)) + qusr unless isMember' $ throwS @'ConvNotFound pure conv diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 8e7d0ab959..c69d977771 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -31,6 +31,7 @@ conversationAPI = mkNamedAPI @"get-unqualified-conversation" getUnqualifiedConversation <@> mkNamedAPI @"get-unqualified-conversation-legalhold-alias" getUnqualifiedConversation <@> mkNamedAPI @"get-conversation" getConversation + <@> mkNamedAPI @"get-global-team-conversation" getGlobalTeamConversation <@> mkNamedAPI @"get-conversation-roles" getConversationRoles <@> mkNamedAPI @"get-group-info" getGroupInfo <@> mkNamedAPI @"list-conversation-ids-unqualified" conversationIdsPageFromUnqualified diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 8b6b19ca72..fabaff7544 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -37,6 +37,7 @@ module Galley.API.Query ( getBotConversationH, getUnqualifiedConversation, getConversation, + getGlobalTeamConversation, getConversationRoles, conversationIdsPageFromUnqualified, conversationIdsPageFrom, @@ -80,6 +81,7 @@ import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E import Galley.Effects.TeamFeatureStore (FeaturePersistentConstraint) import qualified Galley.Effects.TeamFeatureStore as TeamFeatures +import qualified Galley.Effects.TeamStore as E import Galley.Env import Galley.Options import Galley.Types.Conversations.Members @@ -104,6 +106,7 @@ import Wire.API.Error.Galley import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error +import qualified Wire.API.MLS.GlobalTeamConversation as Public import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public import Wire.API.Team.Feature as Public hiding (setStatus) @@ -151,6 +154,26 @@ getUnqualifiedConversation lusr cnv = do c <- getConversationAndCheckMembership (tUnqualified lusr) (qualifyAs lusr cnv) Mapping.conversationView lusr c +getGlobalTeamConversation :: + Members + '[ ConversationStore, + ErrorS 'NotATeamMember, + Error InternalError, + MemberStore, + TeamStore + ] + r => + Local UserId -> + TeamId -> + Sem r Public.GlobalTeamConversation +getGlobalTeamConversation lusr tid = do + let ltid = qualifyAs lusr tid + void $ noteS @'NotATeamMember =<< E.getTeamMember tid (tUnqualified lusr) + E.getGlobalTeamConversation ltid >>= \case + Nothing -> + E.createGlobalTeamConversation (qualifyAs lusr tid) + Just conv -> pure conv + getConversation :: forall r. Members diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 7e79d38213..6fed769289 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -219,21 +219,25 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - forall r. - ( Member BrigAccess r, - Member (ErrorS 'UserBindingExists) r, - Member (ErrorS 'NotConnected) r, - Member GundeckAccess r, - Member (Input UTCTime) r, - Member P.TinyLog r, - Member TeamStore r, - Member WaiRoutes r - ) => - UserId -> + Members + '[ ConversationStore, + ErrorS 'NotConnected, + ErrorS 'UserBindingExists, + GundeckAccess, + Input UTCTime, + MemberStore, + P.TinyLog, + TeamStore, + WaiRoutes, + BrigAccess + ] + r => + Local UserId -> ConnId -> Public.NonBindingNewTeam -> Sem r TeamId -createNonBindingTeamH zusr zcon (Public.NonBindingNewTeam body) = do +createNonBindingTeamH lusr zcon (Public.NonBindingNewTeam body) = do + let zusr = tUnqualified lusr let owner = Public.mkTeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus let others = filter ((zusr /=) . view userId) @@ -254,15 +258,23 @@ createNonBindingTeamH zusr zcon (Public.NonBindingNewTeam body) = do (body ^. newTeamIconKey) NonBinding finishCreateTeam team owner others (Just zcon) - pure (team ^. teamId) + pure $ team ^. teamId createBindingTeam :: - Members '[GundeckAccess, Input UTCTime, TeamStore] r => + Members + '[ GundeckAccess, + Input UTCTime, + MemberStore, + TeamStore, + ConversationStore + ] + r => TeamId -> - UserId -> + Local UserId -> BindingNewTeam -> Sem r TeamId -createBindingTeam tid zusr (BindingNewTeam body) = do +createBindingTeam tid lusr (BindingNewTeam body) = do + let zusr = tUnqualified lusr let owner = Public.mkTeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus team <- E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 29d03b8151..47e1a9182e 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -192,7 +192,7 @@ ensureActionAllowed action self = case isActionAllowed (fromSing action) (convMe ensureGroupConversation :: Member (ErrorS 'InvalidOperation) r => Data.Conversation -> Sem r () ensureGroupConversation conv = do let ty = Data.convType conv - when (ty /= RegularConv) $ throwS @'InvalidOperation + unless (ty `elem` [RegularConv, GlobalTeamConv]) $ throwS @'InvalidOperation -- | Ensure that the set of actions provided are not "greater" than the user's -- own. This is used to ensure users cannot "elevate" allowed actions diff --git a/services/galley/src/Galley/Cassandra/Access.hs b/services/galley/src/Galley/Cassandra/Access.hs index 05c566bfd1..9357320d95 100644 --- a/services/galley/src/Galley/Cassandra/Access.hs +++ b/services/galley/src/Galley/Cassandra/Access.hs @@ -31,6 +31,7 @@ defAccess SelfConv (Just (Set [])) = [PrivateAccess] defAccess ConnectConv (Just (Set [])) = [PrivateAccess] defAccess One2OneConv (Just (Set [])) = [PrivateAccess] defAccess RegularConv (Just (Set [])) = defRegularConvAccess +defAccess GlobalTeamConv s = maybe [SelfInviteAccess] fromSet s defAccess _ (Just (Set (x : xs))) = x : xs privateOnly :: Set Access diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs index 25fb2a44d2..2b7f1c4d9a 100644 --- a/services/galley/src/Galley/Cassandra/Client.hs +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -40,9 +40,10 @@ import Polysemy.Input import qualified UnliftIO updateClient :: Bool -> UserId -> ClientId -> Client () -updateClient add usr cls = do +updateClient add usr cid = do + -- add or remove client let q = if add then Cql.addMemberClient else Cql.rmMemberClient - retry x5 $ write (q cls) (params LocalQuorum (Identity usr)) + retry x5 $ write (q cid) (params LocalQuorum (Identity usr)) -- Do, at most, 16 parallel lookups of up to 128 users each lookupClients :: [UserId] -> Client Clients diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 9c670a017c..d02ecbc473 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -19,6 +19,7 @@ module Galley.Cassandra.Conversation ( createConversation, deleteConversation, interpretConversationStoreToCassandra, + getGlobalTeamConversationById, ) where @@ -54,6 +55,7 @@ import qualified UnliftIO import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite +import Wire.API.MLS.GlobalTeamConversation import Wire.API.MLS.Group import Wire.API.MLS.PublicGroupState @@ -187,7 +189,8 @@ conversationMeta conv = (toConvMeta =<<) <$> retry x1 (query1 Cql.selectConv (params LocalQuorum (Identity conv))) where - toConvMeta (t, c, a, r, r', n, i, _, mt, rm, _, _, _, _) = do + toConvMeta (t, mc, a, r, r', n, i, _, mt, rm, _, _, _, _) = do + c <- mc let mbAccessRolesV2 = Set.fromList . Cql.fromSet <$> r' accessRoles = maybeRole t $ parseAccessRoles r mbAccessRolesV2 pure $ ConversationMetadata t c (defAccess t a) accessRoles n i mt rm @@ -249,6 +252,89 @@ getConversation conv = do <*> UnliftIO.wait cdata runMaybeT $ conversationGC =<< maybe mzero pure mbConv +getGlobalTeamConversation :: + Local TeamId -> + Client (Maybe GlobalTeamConversation) +getGlobalTeamConversation qtid = + let cid = qualifyAs qtid (globalTeamConv (tUnqualified qtid)) + in getGlobalTeamConversationById cid + +getGlobalTeamConversationById :: + Local ConvId -> + Client (Maybe GlobalTeamConversation) +getGlobalTeamConversationById lconv = do + let cid = tUnqualified lconv + mconv <- retry x1 (query1 Cql.selectGlobalTeamConv (params LocalQuorum (Identity cid))) + pure $ toGlobalConv mconv + where + toGlobalConv mconv = do + (muid, mname, mtid, mgid, mepoch, mcs) <- mconv + tid <- mtid + name <- mname + mlsData <- ConversationMLSData <$> mgid <*> (mepoch <|> Just (Epoch 0)) <*> mcs + + pure $ + GlobalTeamConversation + (qUntagged lconv) + mlsData + muid + [SelfInviteAccess] + name + tid + +createGlobalTeamConversation :: + Local TeamId -> + Client GlobalTeamConversation +createGlobalTeamConversation tid = do + let lconv = qualifyAs tid (globalTeamConv $ tUnqualified tid) + gid = convToGroupId lconv + cs = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery + Cql.insertGlobalTeamConv + ( tUnqualified lconv, + Cql.Set [SelfInviteAccess], + "Global team conversation", + tUnqualified tid, + Just gid, + Just cs + ) + addPrepQuery Cql.insertTeamConv (tUnqualified tid, tUnqualified lconv) + addPrepQuery Cql.insertGroupId (gid, tUnqualified lconv, tDomain lconv) + pure $ + GlobalTeamConversation + (qUntagged lconv) + ( ConversationMLSData + gid + (Epoch 0) + cs + ) + Nothing + [SelfInviteAccess] + "Global team conversation" + (tUnqualified tid) + +setGlobalTeamConversationCreator :: + GlobalTeamConversation -> + UserId -> + Client () +setGlobalTeamConversationCreator gtc uid = do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery + Cql.setGlobalTeamConvCreator + ( uid, + qUnqualified . gtcId $ gtc + ) + addPrepQuery + Cql.insertUserConv + ( uid, + qUnqualified . gtcId $ gtc + ) + -- | "Garbage collect" a 'Conversation', i.e. if the conversation is -- marked as deleted, actually remove it from the database and return -- 'Nothing'. @@ -336,10 +422,11 @@ toConv :: ConvId -> [LocalMember] -> [RemoteMember] -> - Maybe (ConvType, UserId, Maybe (Cql.Set Access), Maybe AccessRoleLegacy, Maybe (Cql.Set AccessRoleV2), Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode, Maybe ProtocolTag, Maybe GroupId, Maybe Epoch, Maybe CipherSuiteTag) -> + Maybe (ConvType, Maybe UserId, Maybe (Cql.Set Access), Maybe AccessRoleLegacy, Maybe (Cql.Set AccessRoleV2), Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode, Maybe ProtocolTag, Maybe GroupId, Maybe Epoch, Maybe CipherSuiteTag) -> Maybe Conversation toConv cid ms remoteMems mconv = do - (cty, uid, acc, role, roleV2, nme, ti, del, timer, rm, ptag, mgid, mep, mcs) <- mconv + (cty, muid, acc, role, roleV2, nme, ti, del, timer, rm, ptag, mgid, mep, mcs) <- mconv + uid <- muid let mbAccessRolesV2 = Set.fromList . Cql.fromSet <$> roleV2 accessRoles = maybeRole cty $ parseAccessRoles role mbAccessRolesV2 proto <- toProtocol ptag mgid mep mcs @@ -380,6 +467,10 @@ interpretConversationStoreToCassandra = interpret $ \case CreateConversation loc nc -> embedClient $ createConversation loc nc CreateMLSSelfConversation lusr -> embedClient $ createMLSSelfConversation lusr GetConversation cid -> embedClient $ getConversation cid + GetGlobalTeamConversation tid -> embedClient $ getGlobalTeamConversation tid + GetGlobalTeamConversationById lconv -> embedClient $ getGlobalTeamConversationById lconv + CreateGlobalTeamConversation tid -> embedClient $ createGlobalTeamConversation tid + SetGlobalTeamConversationCreator gtc uid -> embedClient $ setGlobalTeamConversationCreator gtc uid GetConversationIdByGroupId gId -> embedClient $ lookupGroupId gId GetConversations cids -> localConversations cids GetConversationMetadata cid -> embedClient $ conversationMeta cid diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index a4d4622e8c..30a5a4c7da 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -45,7 +45,7 @@ import Imports hiding (Set) import Polysemy import Polysemy.Input import qualified UnliftIO -import Wire.API.Conversation.Member hiding (Member) +import Wire.API.Conversation import Wire.API.Conversation.Role import Wire.API.MLS.KeyPackage import Wire.API.Provider.Service @@ -117,9 +117,32 @@ removeRemoteMembersFromLocalConv cnv victims = do addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) members :: ConvId -> Client [LocalMember] -members conv = - fmap (mapMaybe toMember) . retry x1 $ - query Cql.selectMembers (params LocalQuorum (Identity conv)) +members conv = do + mconv <- retry x1 $ query1 Cql.selectConv (params LocalQuorum (Identity conv)) + case mconv of + Just (GlobalTeamConv, _, _, _, _, _, Just tid, _, _, _, _, _, _, _) -> do + res <- + retry x1 $ + query + Cql.selectTeamMembers + (params LocalQuorum (Identity tid)) + let uids = mapMaybe fst' $ res + pure $ mapMaybe toMemberFromId uids + _ -> + fmap (mapMaybe toMember) . retry x1 $ + query Cql.selectMembers (params LocalQuorum (Identity conv)) + where + fst' (a, _, _, _, _) = Just a + +toMemberFromId :: UserId -> Maybe LocalMember +toMemberFromId usr = + Just $ + LocalMember + { lmId = usr, + lmService = Nothing, + lmStatus = toMemberStatus (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing), + lmConvRoleName = roleNameWireMember + } toMemberStatus :: ( -- otr muted @@ -202,9 +225,15 @@ member :: ConvId -> UserId -> Client (Maybe LocalMember) -member cnv usr = - (toMember =<<) - <$> retry x1 (query1 Cql.selectMember (params LocalQuorum (cnv, usr))) +member conv usr = do + mconv <- retry x1 $ query1 Cql.selectConv (params LocalQuorum (Identity conv)) + case mconv of + Just (GlobalTeamConv, _, _, _, _, _, _, _, _, _, _, _, _, _) -> + pure $ toMemberFromId usr + _ -> do + fmap (toMember =<<) $ + retry x1 $ + query1 Cql.selectMember (params LocalQuorum (conv, usr)) -- | Set local users as belonging to a remote conversation. This is invoked by a -- remote galley when users from the current backend are added to conversations diff --git a/services/galley/src/Galley/Cassandra/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs index 1c4c5aaa40..e9e9764561 100644 --- a/services/galley/src/Galley/Cassandra/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -56,12 +56,14 @@ instance Cql ConvType where toCql SelfConv = CqlInt 1 toCql One2OneConv = CqlInt 2 toCql ConnectConv = CqlInt 3 + toCql GlobalTeamConv = CqlInt 4 fromCql (CqlInt i) = case i of 0 -> pure RegularConv 1 -> pure SelfConv 2 -> pure One2OneConv 3 -> pure ConnectConv + 4 -> pure GlobalTeamConv n -> Left $ "unexpected conversation-type: " ++ show n fromCql _ = Left "conv-type: int expected" @@ -72,12 +74,14 @@ instance Cql Access where toCql InviteAccess = CqlInt 2 toCql LinkAccess = CqlInt 3 toCql CodeAccess = CqlInt 4 + toCql SelfInviteAccess = CqlInt 5 fromCql (CqlInt i) = case i of 1 -> pure PrivateAccess 2 -> pure InviteAccess 3 -> pure LinkAccess 4 -> pure CodeAccess + 5 -> pure SelfInviteAccess n -> Left $ "Unexpected Access value: " ++ show n fromCql _ = Left "Access value: int expected" diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 4ba7f3b76f..2dabd2ab72 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -198,9 +198,40 @@ updateTeamSplashScreen = "update team set splash_screen = ? where team = ?" -- Conversations ------------------------------------------------------------ -selectConv :: PrepQuery R (Identity ConvId) (ConvType, UserId, Maybe (C.Set Access), Maybe AccessRoleLegacy, Maybe (C.Set AccessRoleV2), Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode, Maybe ProtocolTag, Maybe GroupId, Maybe Epoch, Maybe CipherSuiteTag) +selectConv :: + PrepQuery + R + (Identity ConvId) + ( ConvType, + Maybe UserId, + Maybe (C.Set Access), + Maybe AccessRoleLegacy, + Maybe (C.Set AccessRoleV2), + Maybe Text, + Maybe TeamId, + Maybe Bool, + Maybe Milliseconds, + Maybe ReceiptMode, + Maybe ProtocolTag, + Maybe GroupId, + Maybe Epoch, + Maybe CipherSuiteTag + ) selectConv = "select type, creator, access, access_role, access_roles_v2, name, team, deleted, message_timer, receipt_mode, protocol, group_id, epoch, cipher_suite from conversation where conv = ?" +selectGlobalTeamConv :: + PrepQuery + R + (Identity ConvId) + ( Maybe UserId, + Maybe Text, + Maybe TeamId, + Maybe GroupId, + Maybe Epoch, + Maybe CipherSuiteTag + ) +selectGlobalTeamConv = "select creator, name, team, group_id, epoch, cipher_suite from conversation where conv = ?" + selectReceiptMode :: PrepQuery R (Identity ConvId) (Identity (Maybe ReceiptMode)) selectReceiptMode = "select receipt_mode from conversation where conv = ?" @@ -235,6 +266,12 @@ insertMLSSelfConv = <> show (fromEnum ProtocolMLSTag) <> ", ?, ?)" +insertGlobalTeamConv :: PrepQuery W (ConvId, C.Set Access, Text, TeamId, Maybe GroupId, Maybe CipherSuiteTag) () +insertGlobalTeamConv = "insert into conversation (conv, type, access, name, team, group_id, cipher_suite) values (?, 4, ?, ?, ?, ?, ?)" + +setGlobalTeamConvCreator :: PrepQuery W (UserId, ConvId) () +setGlobalTeamConvCreator = "update conversation set creator = ? where conv = ?" + updateConvAccess :: PrepQuery W (C.Set Access, C.Set AccessRoleV2, ConvId) () updateConvAccess = "update conversation set access = ?, access_roles_v2 = ? where conv = ?" diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 1dc85be7a7..52d900f45f 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE LambdaCase #-} module Galley.Cassandra.Team ( interpretTeamStoreToCassandra, @@ -157,23 +158,23 @@ createTeam t uid (fromRange -> n) i k b = do listBillingTeamMembers :: TeamId -> Client [UserId] listBillingTeamMembers tid = - fmap runIdentity - <$> retry x1 (query Cql.listBillingTeamMembers (params LocalQuorum (Identity tid))) + runIdentity + <$$> retry x1 (query Cql.listBillingTeamMembers (params LocalQuorum (Identity tid))) getTeamName :: TeamId -> Client (Maybe Text) getTeamName tid = - fmap runIdentity - <$> retry x1 (query1 Cql.selectTeamName (params LocalQuorum (Identity tid))) + runIdentity + <$$> retry x1 (query1 Cql.selectTeamName (params LocalQuorum (Identity tid))) teamConversation :: TeamId -> ConvId -> Client (Maybe TeamConversation) teamConversation t c = - fmap (newTeamConversation . runIdentity) - <$> retry x1 (query1 Cql.selectTeamConv (params LocalQuorum (t, c))) + newTeamConversation . runIdentity + <$$> retry x1 (query1 Cql.selectTeamConv (params LocalQuorum (t, c))) getTeamConversations :: TeamId -> Client [TeamConversation] getTeamConversations t = - map (newTeamConversation . runIdentity) - <$> retry x1 (query Cql.selectTeamConvs (params LocalQuorum (Identity t))) + newTeamConversation . runIdentity + <$$> retry x1 (query Cql.selectTeamConvs (params LocalQuorum (Identity t))) teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (ResultSet TeamId) teamIdsFrom usr range (fromRange -> max) = @@ -185,7 +186,7 @@ teamIdsFrom usr range (fromRange -> max) = teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (Page TeamId) teamIdsForPagination usr range (fromRange -> max) = - fmap runIdentity <$> case range of + runIdentity <$$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP LocalQuorum (usr, c) max) Nothing -> paginate Cql.selectUserTeams (paramsP LocalQuorum (Identity usr) max) diff --git a/services/galley/src/Galley/Data/Conversation.hs b/services/galley/src/Galley/Data/Conversation.hs index 71f3dcd5ac..3f83ecc9da 100644 --- a/services/galley/src/Galley/Data/Conversation.hs +++ b/services/galley/src/Galley/Data/Conversation.hs @@ -23,6 +23,7 @@ module Galley.Data.Conversation -- * Utilities isConvDeleted, selfConv, + globalTeamConv, localOne2OneConvId, convAccess, convAccessData, @@ -58,6 +59,9 @@ isConvDeleted = convDeleted selfConv :: UserId -> ConvId selfConv uid = Id (toUUID uid) +globalTeamConv :: TeamId -> ConvId +globalTeamConv tid = Id (toUUID tid) + -- | We deduce the conversation ID by adding the 4 components of the V4 UUID -- together pairwise, and then setting the version bits (v4) and variant bits -- (variant 2). This means that we always know what the UUID is for a diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs index 1660c2f689..6c6ac31b08 100644 --- a/services/galley/src/Galley/Effects/ConversationStore.hs +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -28,6 +28,9 @@ module Galley.Effects.ConversationStore -- * Read conversation getConversation, + getGlobalTeamConversation, + getGlobalTeamConversationById, + createGlobalTeamConversation, getConversationIdByGroupId, getConversations, getConversationMetadata, @@ -43,6 +46,7 @@ module Galley.Effects.ConversationStore setConversationReceiptMode, setConversationMessageTimer, setConversationEpoch, + setGlobalTeamConversationCreator, acceptConnectConversation, setGroupId, setPublicGroupState, @@ -68,6 +72,7 @@ import Imports import Polysemy import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.MLS.Epoch +import Wire.API.MLS.GlobalTeamConversation import Wire.API.MLS.PublicGroupState data ConversationStore m a where @@ -78,6 +83,10 @@ data ConversationStore m a where ConversationStore m Conversation DeleteConversation :: ConvId -> ConversationStore m () GetConversation :: ConvId -> ConversationStore m (Maybe Conversation) + GetGlobalTeamConversation :: Local TeamId -> ConversationStore m (Maybe GlobalTeamConversation) + GetGlobalTeamConversationById :: Local ConvId -> ConversationStore m (Maybe GlobalTeamConversation) + CreateGlobalTeamConversation :: Local TeamId -> ConversationStore m GlobalTeamConversation + SetGlobalTeamConversationCreator :: GlobalTeamConversation -> UserId -> ConversationStore m () GetConversationIdByGroupId :: GroupId -> ConversationStore m (Maybe (Qualified ConvId)) GetConversations :: [ConvId] -> ConversationStore m [Conversation] GetConversationMetadata :: ConvId -> ConversationStore m (Maybe ConversationMetadata) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 3f30b17bed..2d95bbb996 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2075,7 +2075,19 @@ postConvQualifiedFederationNotEnabled = do -- FUTUREWORK: figure out how to use functions in the TestM monad inside withSettingsOverrides and remove this duplication postConvHelper :: (MonadIO m, MonadHttp m) => (Request -> Request) -> UserId -> [Qualified UserId] -> m ResponseLBS postConvHelper g zusr newUsers = do - let conv = NewConv [] newUsers (checked "gossip") (Set.fromList []) Nothing Nothing Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing + let conv = + NewConv + [] + newUsers + (checked "gossip") + (Set.fromList []) + Nothing + Nothing + Nothing + Nothing + roleNameWireAdmin + ProtocolProteusTag + Nothing post $ g . path "/conversations" . zUser zusr . zConn "conn" . zType "access" . json conv postSelfConvOk :: TestM () @@ -2104,7 +2116,19 @@ postConvO2OFailWithSelf :: TestM () postConvO2OFailWithSelf = do g <- viewGalley alice <- randomUser - let inv = NewConv [alice] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing + let inv = + NewConv + [alice] + [] + Nothing + mempty + Nothing + Nothing + Nothing + Nothing + roleNameWireAdmin + ProtocolProteusTag + Nothing post (g . path "/conversations/one2one" . zUser alice . zConn "conn" . zType "access" . json inv) !!! do const 403 === statusCode const (Just "invalid-op") === fmap label . responseJsonUnsafe diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 89ef4c2ebd..3a186a9a56 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -1150,3 +1150,5 @@ getConvAction tquery (SomeConversationAction tag action) = (SConversationAccessDataTag, _) -> Nothing (SConversationRemoveMembersTag, SConversationRemoveMembersTag) -> Just action (SConversationRemoveMembersTag, _) -> Nothing + (SConversationSelfInviteTag, SConversationSelfInviteTag) -> Just action + (SConversationSelfInviteTag, _) -> Nothing diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 5de91f2a38..623766cdb4 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -20,11 +20,12 @@ module API.MLS (tests) where import API.MLS.Util -import API.Util +import API.SQS +import API.Util as Util import Bilge hiding (head) import Bilge.Assert import Cassandra -import Control.Lens (view) +import Control.Lens (view, (^.)) import qualified Control.Monad.State as State import Crypto.Error import qualified Crypto.PubKey.Ed25519 as Ed25519 @@ -45,6 +46,8 @@ import Data.String.Conversions import qualified Data.Text as T import Data.Time import Federator.MockServer hiding (withTempMockFederator) +import Galley.Data.Conversation +import Galley.Options import Imports import qualified Network.Wai.Utilities.Error as Wai import Test.QuickCheck (Arbitrary (arbitrary), generate) @@ -61,11 +64,15 @@ import Wire.API.Conversation.Role import Wire.API.Error.Galley import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley +import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential +import Wire.API.MLS.GlobalTeamConversation +import Wire.API.MLS.Group import Wire.API.MLS.Keys import Wire.API.MLS.Serialisation import Wire.API.MLS.Welcome import Wire.API.Message +import Wire.API.Team (teamCreator) import Wire.API.User.Client tests :: IO TestSetup -> TestTree @@ -186,6 +193,15 @@ tests s = test s "add user with a commit bundle to a remote conversation" testAddUserToRemoteConvWithBundle, test s "remote user posts commit bundle" testRemoteUserPostsCommitBundle ], + testGroup + "GlobalTeamConv" + [ test s "Non-existing team returns 403" testGetGlobalTeamConvNonExistant, + test s "Non member of team returns 403" testGetGlobalTeamConvNonMember, + test s "Global team conversation is created on get if not present" (testGetGlobalTeamConv s), + test s "Can't leave global team conversation" testGlobalTeamConversationLeave, + test s "Send message in global team conversation" testGlobalTeamConversationMessage, + test s "Listing convs includes global team conversation" testConvListIncludesGlobal + ], testGroup "Self conversation" [ test s "create a self conversation" testSelfConversation, @@ -385,7 +401,7 @@ testAddUserWithBundleIncompleteWelcome = do bundle <- createBundle commit err <- responseJsonError - =<< postCommitBundle (ciUser (mpSender commit)) bundle + =<< postCommitBundle (mpSender commit) bundle getGroupInfo (ciUser alice1) qcnv mp <- createExternalCommit bob1 (Just pgs) qcnv bundle <- createBundle mp - postCommitBundle (ciUser (mpSender mp)) bundle + postCommitBundle (mpSender mp) bundle !!! const 404 === statusCode testExternalCommitSameClient :: TestM () @@ -2040,7 +2056,7 @@ testDeleteMLSConv :: TestM () testDeleteMLSConv = do localDomain <- viewFederationDomain -- c <- view tsCannon - (tid, aliceUnq, [bobUnq]) <- API.Util.createBindingTeamWithMembers 2 + (tid, aliceUnq, [bobUnq]) <- Util.createBindingTeamWithMembers 2 let alice = Qualified aliceUnq localDomain bob = Qualified bobUnq localDomain @@ -2139,6 +2155,184 @@ testRemoteUserPostsCommitBundle = do pure () +testGetGlobalTeamConvNonExistant :: TestM () +testGetGlobalTeamConvNonExistant = do + uid <- randomUser + tid <- randomId + -- authorisation fails b/c not a team member + getGlobalTeamConv uid tid !!! const 403 === statusCode + +testGetGlobalTeamConvNonMember :: TestM () +testGetGlobalTeamConvNonMember = do + owner <- randomUser + tid <- createBindingTeamInternal "sample-team" owner + team <- getTeam owner tid + assertQueue "create team" tActivate + liftIO $ assertEqual "owner" owner (team ^. teamCreator) + assertQueueEmpty + + -- authorisation fails b/c not a team member + uid <- randomUser + getGlobalTeamConv uid tid !!! const 403 === statusCode + +testGetGlobalTeamConv :: IO TestSetup -> TestM () +testGetGlobalTeamConv setup = do + owner <- randomUser + tid <- createBindingTeamInternal "sample-team" owner + team <- getTeam owner tid + assertQueue "create team" tActivate + liftIO $ assertEqual "owner" owner (team ^. teamCreator) + assertQueueEmpty + + s <- liftIO setup + let domain = s ^. tsGConf . optSettings . setFederationDomain + + let response = getGlobalTeamConv owner tid response + let convoId = globalTeamConv tid + lconv = toLocalUnsafe domain convoId + expected = + GlobalTeamConversation + (qUntagged lconv) + ( ConversationMLSData + (convToGroupId lconv) + (Epoch 0) + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + ) + Nothing + [SelfInviteAccess] + "Global team conversation" + tid + + let cm = Aeson.decode rs :: Maybe GlobalTeamConversation + liftIO $ assertEqual "conversation metadata" cm (Just expected) + +testConvListIncludesGlobal :: TestM () +testConvListIncludesGlobal = do + aliceQ <- randomQualifiedUser + let alice = qUnqualified aliceQ + tid <- createBindingTeamInternal "sample-team" alice + team <- getTeam alice tid + assertQueue "create team" tActivate + liftIO $ assertEqual "alice" alice (team ^. teamCreator) + assertQueueEmpty + + -- global team conv doesn't yet include user + let paginationOpts = GetPaginatedConversationIds Nothing (toRange (Proxy @5)) + listConvIds alice paginationOpts !!! do + const 200 === statusCode + const (Just [globalTeamConv tid]) =/~= (rightToMaybe . (<$$>) qUnqualified . decodeQualifiedConvIdList) + + -- add user to conv + runMLSTest $ do + alice1 <- createMLSClient aliceQ + + let response = getGlobalTeamConv alice tid response + let (Just gtc) = Aeson.decode rs :: Maybe GlobalTeamConversation + gid = cnvmlsGroupId $ gtcMlsMetadata gtc + + void $ uploadNewKeyPackage alice1 + + -- create mls group + createGroup alice1 gid + void $ createAddCommit alice1 [] >>= sendAndConsumeCommitBundle + + -- Now we should have the user as part of that conversation also in the backend + listConvIds alice paginationOpts !!! do + const 200 === statusCode + const (Just [globalTeamConv tid]) =~= (rightToMaybe . (<$$>) qUnqualified . decodeQualifiedConvIdList) + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe = either (const Nothing) Just + +testGlobalTeamConversationMessage :: TestM () +testGlobalTeamConversationMessage = do + alice <- randomQualifiedUser + let aliceUnq = qUnqualified alice + + tid <- createBindingTeamInternal "sample-team" aliceUnq + team <- getTeam aliceUnq tid + assertQueue "create team" tActivate + liftIO $ assertEqual "owner" aliceUnq (team ^. teamCreator) + assertQueueEmpty + + runMLSTest $ do + clients@[alice1, alice2, alice3] <- traverse createMLSClient (replicate 3 alice) + + let response = getGlobalTeamConv aliceUnq tid response + let (Just gtc) = Aeson.decode rs :: Maybe GlobalTeamConversation + qcnv = gtcId gtc + gid = cnvmlsGroupId $ gtcMlsMetadata gtc + + traverse_ uploadNewKeyPackage clients + + createGroup alice1 gid + void $ createAddCommit alice1 [] >>= sendAndConsumeCommitBundle + + pgs <- + LBS.toStrict . fromJust . responseBody + <$> getGroupInfo (ciUser alice1) qcnv + void $ createExternalCommit alice2 (Just pgs) qcnv >>= sendAndConsumeCommitBundle + + -- FUTUREWORK: add tests for race conditions when adding two commits with same epoch? + -- TODO(elland): test racing conditions for get global team conv + pgs' <- + LBS.toStrict . fromJust . responseBody + <$> getGroupInfo (ciUser alice1) qcnv + void $ createExternalCommit alice3 (Just pgs') qcnv >>= sendAndConsumeCommitBundle + + do + message <- createApplicationMessage alice1 "some text" + + mlsBracket [alice2, alice3] $ \wss -> do + events <- sendAndConsumeMessage message + liftIO $ events @?= [] + liftIO $ + WS.assertMatchN_ (5 # WS.Second) wss $ + wsAssertMLSMessage qcnv alice (mpMessage message) + + do + message <- createApplicationMessage alice2 "some text new" + + mlsBracket [alice1, alice3] $ \wss -> do + events <- sendAndConsumeMessage message + liftIO $ events @?= [] + liftIO $ + WS.assertMatchN_ (5 # WS.Second) wss $ + wsAssertMLSMessage qcnv alice (mpMessage message) + +testGlobalTeamConversationLeave :: TestM () +testGlobalTeamConversationLeave = do + alice <- randomQualifiedUser + let aliceUnq = qUnqualified alice + + tid <- createBindingTeamInternal "sample-team" aliceUnq + team <- getTeam aliceUnq tid + assertQueue "create team" tActivate + liftIO $ assertEqual "owner" aliceUnq (team ^. teamCreator) + assertQueueEmpty + + runMLSTest $ do + alice1 <- createMLSClient alice + + let response = getGlobalTeamConv aliceUnq tid response + let (Just gtc) = Aeson.decode rs :: Maybe GlobalTeamConversation + gid = cnvmlsGroupId $ gtcMlsMetadata gtc + + void $ uploadNewKeyPackage alice1 + createGroup alice1 gid + void $ createAddCommit alice1 [] >>= sendAndConsumeCommitBundle + mlsBracket [alice1] $ \wss -> do + liftTest $ + deleteMemberQualified (qUnqualified alice) alice (gtcId gtc) + !!! do + const 403 === statusCode + const (Just "invalid-op") === fmap Wai.label . responseJsonError + WS.assertNoEvent (1 # WS.Second) wss + testSelfConversation :: TestM () testSelfConversation = do alice <- randomQualifiedUser diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 5e2c332550..59d9e89be1 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -130,7 +130,7 @@ postCommitBundle :: MonadHttp m, HasGalley m ) => - UserId -> + ClientIdentity -> ByteString -> m ResponseLBS postCommitBundle sender bundle = do @@ -138,7 +138,8 @@ postCommitBundle sender bundle = do post ( galley . paths ["mls", "commit-bundles"] - . zUser sender + . zUser (ciUser sender) + . zClient (ciClient sender) . zConn "conn" . content "application/x-protobuf" . bytes bundle @@ -641,13 +642,13 @@ createAddCommitWithKeyPackages qcid clientsAndKeyPackages = do { mlsNewMembers = Set.fromList (map fst clientsAndKeyPackages) } - welcome <- liftIO $ BS.readFile welcomeFile + welcome <- liftIO $ readWelcome welcomeFile pgs <- liftIO $ BS.readFile pgsFile pure $ MessagePackage { mpSender = qcid, mpMessage = commit, - mpWelcome = Just welcome, + mpWelcome = welcome, mpPublicGroupState = Just pgs } @@ -862,7 +863,7 @@ sendAndConsumeCommit mp = do pure events -mkBundle :: MessagePackage -> Either Text CommitBundle +mkBundle :: HasCallStack => MessagePackage -> Either Text CommitBundle mkBundle mp = do commitB <- decodeMLS' (mpMessage mp) welcomeB <- traverse decodeMLS' (mpWelcome mp) @@ -872,7 +873,7 @@ mkBundle mp = do CommitBundle commitB welcomeB $ GroupInfoBundle UnencryptedGroupInfo TreeFull pgsB -createBundle :: MonadIO m => MessagePackage -> m ByteString +createBundle :: (HasCallStack, MonadIO m) => MessagePackage -> m ByteString createBundle mp = do bundle <- either (liftIO . assertFailure . T.unpack) pure $ @@ -888,7 +889,7 @@ sendAndConsumeCommitBundle mp = do events <- fmap mmssEvents . responseJsonError - =<< postCommitBundle (ciUser (mpSender mp)) bundle + =<< postCommitBundle (mpSender mp) bundle >= checkTeamList Nothing + let getTeams' = Util.getTeams owner + getTeams' [] >>= checkTeamList Nothing tid <- Util.createBindingTeamInternal "foo" owner <* assertQueue "create team" tActivate wrongTid <- (Util.randomUser >>= Util.createBindingTeamInternal "foobar") <* assertQueue "create team" tActivate - Util.getTeams owner [] >>= checkTeamList (Just tid) - Util.getTeams owner [("size", Just "1")] >>= checkTeamList (Just tid) - Util.getTeams owner [("ids", Just $ toByteString' tid)] >>= checkTeamList (Just tid) - Util.getTeams owner [("ids", Just $ toByteString' tid <> "," <> toByteString' wrongTid)] >>= checkTeamList (Just tid) + getTeams' [] >>= checkTeamList (Just tid) + getTeams' [("size", Just "1")] >>= checkTeamList (Just tid) + getTeams' [("ids", Just $ toByteString' tid)] >>= checkTeamList (Just tid) + getTeams' [("ids", Just $ toByteString' tid <> "," <> toByteString' wrongTid)] >>= checkTeamList (Just tid) -- these two queries do not yield responses that are equivalent to the old wai route API - Util.getTeams owner [("ids", Just $ toByteString' wrongTid)] >>= checkTeamList (Just tid) - Util.getTeams owner [("start", Just $ toByteString' tid)] >>= checkTeamList (Just tid) + getTeams' [("ids", Just $ toByteString' wrongTid)] >>= checkTeamList (Just tid) + getTeams' [("start", Just $ toByteString' tid)] >>= checkTeamList (Just tid) where checkTeamList :: Maybe TeamId -> TeamList -> TestM () checkTeamList mbTid tl = liftIO $ do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 3df6b0271d..205505d51a 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -7,7 +7,6 @@ -- Software Foundation, either version 3 of the License, or (at your option) any -- later version. -- - -- This program is distributed in the hope that it will be useful, but WITHOUT -- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more @@ -15,6 +14,9 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use head" #-} module API.Teams.Feature (tests) where diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index a02b492911..e0d63c2726 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -15,6 +15,9 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use head" #-} module API.Util where @@ -275,9 +278,17 @@ createBindingTeamInternalNoActivate name owner = do tid <- randomId let nt = BindingNewTeam $ newNewTeam (unsafeRange name) DefaultIcon _ <- - put (g . paths ["/i/teams", toByteString' tid] . zUser owner . zConn "conn" . zType "access" . json nt) Text -> UserId -> Currency.Alpha -> TestM TeamId @@ -606,7 +617,18 @@ createTeamConvAccessRaw u tid us name acc role mtimer convRole = do g <- viewGalley let tinfo = ConvTeamInfo tid let conv = - NewConv us [] (name >>= checked) (fromMaybe (Set.fromList []) acc) role (Just tinfo) mtimer Nothing (fromMaybe roleNameWireAdmin convRole) ProtocolProteusTag Nothing + NewConv + us + [] + (name >>= checked) + (fromMaybe (Set.fromList []) acc) + role + (Just tinfo) + mtimer + Nothing + (fromMaybe roleNameWireAdmin convRole) + ProtocolProteusTag + Nothing post ( g . path "/conversations" @@ -673,7 +695,18 @@ createOne2OneTeamConv :: UserId -> UserId -> Maybe Text -> TeamId -> TestM Respo createOne2OneTeamConv u1 u2 n tid = do g <- viewGalley let conv = - NewConv [u2] [] (n >>= checked) mempty Nothing (Just $ ConvTeamInfo tid) Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing + NewConv + [u2] + [] + (n >>= checked) + mempty + Nothing + (Just $ ConvTeamInfo tid) + Nothing + Nothing + roleNameWireAdmin + ProtocolProteusTag + Nothing post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv postConv :: @@ -729,7 +762,19 @@ postConvWithRemoteUsers u n = postTeamConv :: TeamId -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> TestM ResponseLBS postTeamConv tid u us name a r mtimer = do g <- viewGalley - let conv = NewConv us [] (name >>= checked) (Set.fromList a) r (Just (ConvTeamInfo tid)) mtimer Nothing roleNameWireAdmin ProtocolProteusTag Nothing + let conv = + NewConv + us + [] + (name >>= checked) + (Set.fromList a) + r + (Just (ConvTeamInfo tid)) + mtimer + Nothing + roleNameWireAdmin + ProtocolProteusTag + Nothing post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv deleteTeamConv :: (HasGalley m, MonadIO m, MonadHttp m) => TeamId -> ConvId -> UserId -> m ResponseLBS @@ -766,7 +811,19 @@ postConvWithRole u members name access arole timer role = postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS postConvWithReceipt u us name a r mtimer rcpt = do g <- viewGalley - let conv = NewConv us [] (name >>= checked) (Set.fromList a) r Nothing mtimer (Just rcpt) roleNameWireAdmin ProtocolProteusTag Nothing + let conv = + NewConv + us + [] + (name >>= checked) + (Set.fromList a) + r + Nothing + mtimer + (Just rcpt) + roleNameWireAdmin + ProtocolProteusTag + Nothing post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv postSelfConv :: UserId -> TestM ResponseLBS @@ -777,7 +834,19 @@ postSelfConv u = do postO2OConv :: UserId -> UserId -> Maybe Text -> TestM ResponseLBS postO2OConv u1 u2 n = do g <- viewGalley - let conv = NewConv [u2] [] (n >>= checked) mempty Nothing Nothing Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing + let conv = + NewConv + [u2] + [] + (n >>= checked) + mempty + Nothing + Nothing + Nothing + Nothing + roleNameWireAdmin + ProtocolProteusTag + Nothing post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS @@ -1018,6 +1087,20 @@ getConv u c = do . zConn "conn" . zType "access" +getGlobalTeamConv :: + (MonadIO m, MonadHttp m, HasGalley m, HasCallStack) => + UserId -> + TeamId -> + m ResponseLBS +getGlobalTeamConv u tid = do + g <- viewGalley + get $ + g + . paths ["teams", toByteString' tid, "conversations", "global"] + . zUser u + . zConn "conn" + . zType "access" + getConvQualified :: (MonadIO m, MonadHttp m, HasGalley m, HasCallStack) => UserId -> Qualified ConvId -> m ResponseLBS getConvQualified u (Qualified conv domain) = do g <- viewGalley @@ -1842,12 +1925,12 @@ decodeQualifiedConvIdList = fmap mtpResults . responseJsonEither @ConvIdsPage zUser :: UserId -> Request -> Request zUser = header "Z-User" . toByteString' -zBot :: UserId -> Request -> Request -zBot = header "Z-Bot" . toByteString' - zClient :: ClientId -> Request -> Request zClient = header "Z-Client" . toByteString' +zBot :: UserId -> Request -> Request +zBot = header "Z-Bot" . toByteString' + zConn :: ByteString -> Request -> Request zConn = header "Z-Connection" diff --git a/services/galley/test/unit/Test/Galley/Intra/User.hs b/services/galley/test/unit/Test/Galley/Intra/User.hs index c6bec86487..1138e79f0a 100644 --- a/services/galley/test/unit/Test/Galley/Intra/User.hs +++ b/services/galley/test/unit/Test/Galley/Intra/User.hs @@ -20,7 +20,6 @@ module Test.Galley.Intra.User where --- import Debug.Trace (traceShow) import Galley.Intra.User (chunkify) import Imports import Test.QuickCheck diff --git a/tools/db/migrate-sso-feature-flag/src/Work.hs b/tools/db/migrate-sso-feature-flag/src/Work.hs index 9223659ed1..b8b09cfe8f 100644 --- a/tools/db/migrate-sso-feature-flag/src/Work.hs +++ b/tools/db/migrate-sso-feature-flag/src/Work.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. -- @@ -28,12 +28,10 @@ import Data.Conduit import Data.Conduit.Internal (zipSources) import qualified Data.Conduit.List as C import Data.Id -import Data.Misc import Galley.Cassandra.Instances () import Imports import System.Logger (Logger) import qualified System.Logger as Log -import UnliftIO.Async (pooledMapConcurrentlyN) import Wire.API.Team.Feature import Wire.API.User diff --git a/tools/db/move-team/src/Work.hs b/tools/db/move-team/src/Work.hs index a10a9a13f8..8ec807152f 100644 --- a/tools/db/move-team/src/Work.hs +++ b/tools/db/move-team/src/Work.hs @@ -4,7 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. --