diff --git a/changelog.d/5-internal/refactor-tagged-qualified b/changelog.d/5-internal/refactor-tagged-qualified new file mode 100644 index 0000000000..e884a8bb70 --- /dev/null +++ b/changelog.d/5-internal/refactor-tagged-qualified @@ -0,0 +1 @@ +Improve the `Qualified` abstraction and make local/remote tagging safer diff --git a/changelog.d/6-federation/unqualify-conv-id b/changelog.d/6-federation/unqualify-conv-id new file mode 100644 index 0000000000..65579183b1 --- /dev/null +++ b/changelog.d/6-federation/unqualify-conv-id @@ -0,0 +1 @@ +Make conversation ID of `RemoteConversation` unqualified and move it out of the metadata record. diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index 6b0a86f099..e9f69bbb43 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -24,7 +24,6 @@ module Galley.Types -- * re-exports ConversationMetadata (..), Conversation (..), - cnvQualifiedId, cnvType, cnvCreator, cnvAccess, diff --git a/libs/galley-types/src/Galley/Types/Conversations/Members.hs b/libs/galley-types/src/Galley/Types/Conversations/Members.hs index 7e6a88c6db..42a3fb9dda 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Members.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Members.hs @@ -30,7 +30,6 @@ where import Data.Domain import Data.Id as Id import Data.Qualified -import Data.Tagged import Imports import Wire.API.Conversation import Wire.API.Conversation.Role (RoleName) @@ -46,7 +45,7 @@ data RemoteMember = RemoteMember remoteMemberToOther :: RemoteMember -> OtherMember remoteMemberToOther x = OtherMember - { omQualifiedId = unTagged (rmId x), + { omQualifiedId = qUntagged (rmId x), omService = Nothing, omConvRoleName = rmConvRoleName x } diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index c06c897b7b..60f418eba1 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -22,7 +21,36 @@ -- for UUID instances -module Data.Id where +module Data.Id + ( -- * Tagged IDs + Id (..), + IdTag, + KnownIdTag (..), + idTagName, + randomId, + AssetId, + InvitationId, + ConvId, + UserId, + ProviderId, + ServiceId, + TeamId, + ScimTokenId, + parseIdFromText, + idToText, + IdObject (..), + + -- * Client IDs + ClientId (..), + newClientId, + + -- * Other IDs + ConnId (..), + RequestId (..), + BotId (..), + NoId, + ) +where import Cassandra hiding (S) import Control.Lens ((?~)) @@ -56,39 +84,54 @@ import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Test.QuickCheck import Test.QuickCheck.Instances () -data A +data IdTag = A | C | I | U | P | S | T | STo -data C +idTagName :: IdTag -> Text +idTagName A = "Asset" +idTagName C = "Conv" +idTagName I = "Invitation" +idTagName U = "User" +idTagName P = "Provider" +idTagName S = "Service" +idTagName T = "Team" +idTagName STo = "ScimToken" -data I +class KnownIdTag (t :: IdTag) where + idTagValue :: IdTag -data U +instance KnownIdTag 'A where idTagValue = A -data P +instance KnownIdTag 'C where idTagValue = C -data S +instance KnownIdTag 'I where idTagValue = I -data T +instance KnownIdTag 'U where idTagValue = U -data STo +instance KnownIdTag 'P where idTagValue = P -type AssetId = Id A +instance KnownIdTag 'S where idTagValue = S -type InvitationId = Id I +instance KnownIdTag 'T where idTagValue = T + +instance KnownIdTag 'STo where idTagValue = STo + +type AssetId = Id 'A + +type InvitationId = Id 'I -- | A local conversation ID -type ConvId = Id C +type ConvId = Id 'C -- | A local user ID -type UserId = Id U +type UserId = Id 'U -type ProviderId = Id P +type ProviderId = Id 'P -type ServiceId = Id S +type ServiceId = Id 'S -type TeamId = Id T +type TeamId = Id 'T -type ScimTokenId = Id STo +type ScimTokenId = Id 'STo -- Id ------------------------------------------------------------------------- diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index cb0214a710..2f731095dd 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -350,5 +350,5 @@ instance Arbitrary PlainTextPassword where -- -- Example: -- >>> let (FutureWork @'LegalholdPlusFederationNotImplemented -> _remoteUsers, localUsers) --- >>> = partitionRemoteOrLocalIds domain qualifiedUids +-- >>> = partitionQualified domain qualifiedUids newtype FutureWork label payload = FutureWork payload diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 6a01d6d10a..84b6eb1572 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE StrictData #-} @@ -21,35 +22,33 @@ module Data.Qualified ( -- * Qualified Qualified (..), + QualifiedWithTag, + tUnqualified, + tUnqualifiedL, + tDomain, + qUntagged, + qTagUnsafe, Remote, - toRemote, + toRemoteUnsafe, Local, - toLocal, - lUnqualified, - lDomain, + toLocalUnsafe, qualifyAs, foldQualified, - renderQualifiedId, - partitionRemoteOrLocalIds, - partitionRemoteOrLocalIds', partitionQualified, + indexQualified, + indexRemote, deprecatedSchema, - partitionRemote, ) where -import Control.Lens ((?~)) +import Control.Lens (Lens, lens, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) -import Data.Bifunctor (first) -import Data.Domain (Domain, domainText) +import Data.Domain (Domain) import Data.Handle (Handle (..)) -import Data.Id (Id (toUUID)) +import Data.Id import qualified Data.Map as Map import Data.Schema -import Data.String.Conversions (cs) import qualified Data.Swagger as S -import Data.Tagged -import qualified Data.UUID as UUID import Imports hiding (local) import Test.QuickCheck (Arbitrary (arbitrary)) @@ -62,72 +61,85 @@ data Qualified a = Qualified } deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) --- | A type to differentiate between generally Qualified values, and values --- where it is known if they are coming from a Remote backend or not. --- Use 'toRemote' or 'partitionRemoteOrLocalIds\'' to get Remote values and use --- 'unTagged' to convert from a Remote value back to a plain Qualified one. -type Remote a = Tagged "remote" (Qualified a) +data QTag = QLocal | QRemote + deriving (Eq, Show) --- | Convert a Qualified something to a Remote something. -toRemote :: Qualified a -> Remote a -toRemote = Tagged +-- | A type to differentiate between generally 'Qualified' values, and "tagged" values, +-- for which it is known whether they are coming from a remote or local backend. +-- Use 'foldQualified', 'partitionQualified' or 'qualifyLocal' to get tagged values and use +-- 'qUntagged' to convert from a tagged value back to a plain 'Qualified' one. +newtype QualifiedWithTag (t :: QTag) a = QualifiedWithTag {qUntagged :: Qualified a} + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + deriving newtype (Arbitrary) --- | A type representing a Qualified value where the domain is guaranteed to be --- the local one. -type Local a = Tagged "local" (Qualified a) +qTagUnsafe :: forall t a. Qualified a -> QualifiedWithTag t a +qTagUnsafe = QualifiedWithTag -toLocal :: Qualified a -> Local a -toLocal = Tagged +tUnqualified :: QualifiedWithTag t a -> a +tUnqualified = qUnqualified . qUntagged -lUnqualified :: Local a -> a -lUnqualified = qUnqualified . unTagged +tDomain :: QualifiedWithTag t a -> Domain +tDomain = qDomain . qUntagged -lDomain :: Local a -> Domain -lDomain = qDomain . unTagged +tUnqualifiedL :: Lens (QualifiedWithTag t a) (QualifiedWithTag t b) a b +tUnqualifiedL = lens tUnqualified qualifyAs + +-- | A type representing a 'Qualified' value where the domain is guaranteed to +-- be remote. +type Remote = QualifiedWithTag 'QRemote + +-- | Convert a 'Domain' and an @a@ to a 'Remote' value. This is only safe if we +-- already know that the domain is remote. +toRemoteUnsafe :: Domain -> a -> Remote a +toRemoteUnsafe d a = qTagUnsafe $ Qualified a d + +-- | A type representing a 'Qualified' value where the domain is guaranteed to +-- be local. +type Local = QualifiedWithTag 'QLocal + +-- | Convert a 'Domain' and an @a@ to a 'Local' value. This is only safe if we +-- already know that the domain is local. +toLocalUnsafe :: Domain -> a -> Local a +toLocalUnsafe d a = qTagUnsafe $ Qualified a d -- | Convert an unqualified value to a qualified one, with the same tag as the -- given tagged qualified value. -qualifyAs :: Tagged t (Qualified x) -> a -> Tagged t (Qualified a) -qualifyAs (Tagged q) x = Tagged (q $> x) +qualifyAs :: QualifiedWithTag t x -> a -> QualifiedWithTag t a +qualifyAs = ($>) foldQualified :: Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b foldQualified loc f g q - | lDomain loc == qDomain q = - f (toLocal q) + | tDomain loc == qDomain q = + f (qTagUnsafe q) | otherwise = - g (toRemote q) - --- | FUTUREWORK: Maybe delete this, it is only used in printing federation not --- implemented errors -renderQualified :: (a -> Text) -> Qualified a -> Text -renderQualified renderLocal (Qualified localPart domain) = - renderLocal localPart <> "@" <> domainText domain - --- FUTUREWORK: we probably want to use the primed function everywhere. Refactor these two functions to only have one. -partitionRemoteOrLocalIds :: Foldable f => Domain -> f (Qualified a) -> ([Qualified a], [a]) -partitionRemoteOrLocalIds localDomain = foldMap $ \qualifiedId -> - if qDomain qualifiedId == localDomain - then (mempty, [qUnqualified qualifiedId]) - else ([qualifiedId], mempty) - -partitionRemoteOrLocalIds' :: Foldable f => Domain -> f (Qualified a) -> ([Remote a], [a]) -partitionRemoteOrLocalIds' localDomain xs = first (fmap toRemote) $ partitionRemoteOrLocalIds localDomain xs - --- | Index a list of qualified values by domain -partitionQualified :: Foldable f => f (Qualified a) -> Map Domain [a] -partitionQualified = foldr add mempty + g (qTagUnsafe q) + +-- Partition a collection of qualified values into locals and remotes. +-- +-- Note that the local values are returned as unqualified values, as a (probably +-- insignificant) optimisation. Use 'partitionQualifiedAndTag' to get them as +-- 'Local' values. +partitionQualified :: Foldable f => Local x -> f (Qualified a) -> ([a], [Remote a]) +partitionQualified loc = + foldMap $ + foldQualified loc (\l -> ([tUnqualified l], mempty)) (\r -> (mempty, [r])) + +-- | Index a list of qualified values by domain. +indexQualified :: Foldable f => f (Qualified a) -> Map Domain [a] +indexQualified = foldr add mempty where add :: Qualified a -> Map Domain [a] -> Map Domain [a] add (Qualified x domain) = Map.insertWith (<>) domain [x] -partitionRemote :: (Functor f, Foldable f) => f (Remote a) -> [(Domain, [a])] -partitionRemote remotes = Map.assocs $ partitionQualified (unTagged <$> remotes) +indexRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]] +indexRemote = + map (uncurry toRemoteUnsafe) + . Map.assocs + . indexQualified + . fmap qUntagged ---------------------------------------------------------------------- -renderQualifiedId :: Qualified (Id a) -> Text -renderQualifiedId = renderQualified (cs . UUID.toString . toUUID) - deprecatedSchema :: S.HasDescription doc (Maybe Text) => Text -> ValueSchema doc a -> ValueSchema doc a deprecatedSchema new = doc . description ?~ ("Deprecated, use " <> new) @@ -142,19 +154,19 @@ qualifiedSchema name fieldName sch = <$> qUnqualified .= field fieldName sch <*> qDomain .= field "domain" schema -instance ToSchema (Qualified (Id a)) where - schema = qualifiedSchema "UserId" "id" schema +instance KnownIdTag t => ToSchema (Qualified (Id t)) where + schema = qualifiedSchema (idTagName (idTagValue @t) <> "Id") "id" schema instance ToSchema (Qualified Handle) where schema = qualifiedSchema "Handle" "handle" schema -instance ToJSON (Qualified (Id a)) where +instance KnownIdTag t => ToJSON (Qualified (Id t)) where toJSON = schemaToJSON -instance FromJSON (Qualified (Id a)) where +instance KnownIdTag t => FromJSON (Qualified (Id t)) where parseJSON = schemaParseJSON -instance S.ToSchema (Qualified (Id a)) where +instance KnownIdTag t => S.ToSchema (Qualified (Id t)) where declareNamedSchema = schemaToSwagger instance ToJSON (Qualified Handle) where diff --git a/libs/types-common/test/Test/Qualified.hs b/libs/types-common/test/Test/Qualified.hs index 8e11f79103..1787d475a9 100644 --- a/libs/types-common/test/Test/Qualified.hs +++ b/libs/types-common/test/Test/Qualified.hs @@ -22,14 +22,11 @@ where import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) import qualified Data.Aeson.Types as Aeson -import Data.Domain (Domain (..)) import Data.Handle (Handle) -import Data.Id (Id (..), UserId) -import Data.Qualified (Qualified (..), renderQualifiedId) -import qualified Data.UUID as UUID +import Data.Id (UserId) +import Data.Qualified (Qualified (..)) import Imports import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Type.Reflection (typeRep) @@ -42,13 +39,7 @@ tests = testQualifiedSerialization :: [TestTree] testQualifiedSerialization = - [ testCase "render 61a73a52-e526-4892-82a9-3d638d77629f@example.com" $ do - uuid <- - maybe (assertFailure "invalid UUID") pure $ - UUID.fromString "61a73a52-e526-4892-82a9-3d638d77629f" - assertEqual "" "61a73a52-e526-4892-82a9-3d638d77629f@example.com" $ - (renderQualifiedId (Qualified (Id uuid) (Domain "example.com"))), - jsonRoundtrip @(Qualified Handle), + [ jsonRoundtrip @(Qualified Handle), jsonRoundtrip @(Qualified UserId) ] 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 f3524abfb8..7a8f3b5b4a 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 @@ -127,7 +127,10 @@ data RemoteConvMembers = RemoteConvMembers -- fields (muted/archived/hidden) are omitted, since they are not known by the -- remote backend. data RemoteConversation = RemoteConversation - { rcnvMetadata :: ConversationMetadata, + { -- | Id of the conversation, implicitly qualified with the domain of the + -- backend that created this value. + rcnvId :: ConvId, + rcnvMetadata :: ConversationMetadata, rcnvMembers :: RemoteConvMembers } deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index e65b0e0a88..49412c9d85 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -25,7 +25,6 @@ module Wire.API.Conversation ConversationMetadata (..), Conversation (..), mkConversation, - cnvQualifiedId, cnvType, cnvCreator, cnvAccess, @@ -116,9 +115,7 @@ import Wire.API.Routes.MultiTablePaging -- Conversation data ConversationMetadata = ConversationMetadata - { -- | A qualified conversation ID - cnvmQualifiedId :: Qualified ConvId, - cnvmType :: ConvType, + { cnvmType :: ConvType, -- FUTUREWORK: Make this a qualified user ID. cnvmCreator :: UserId, cnvmAccess :: [Access], @@ -143,10 +140,7 @@ conversationMetadataObjectSchema :: ConversationMetadata conversationMetadataObjectSchema = ConversationMetadata - <$> cnvmQualifiedId .= field "qualified_id" schema - <* (qUnqualified . cnvmQualifiedId) - .= optional (field "id" (deprecatedSchema "qualified_id" schema)) - <*> cnvmType .= field "type" schema + <$> cnvmType .= field "type" schema <*> cnvmCreator .= fieldWithDocModifier "creator" @@ -177,7 +171,9 @@ instance ToSchema ConversationMetadata where -- Can be produced from the internal one ('Galley.Data.Types.Conversation') -- by using 'Galley.API.Mapping.conversationView'. data Conversation = Conversation - { cnvMetadata :: ConversationMetadata, + { -- | A qualified conversation ID + cnvQualifiedId :: Qualified ConvId, + cnvMetadata :: ConversationMetadata, cnvMembers :: ConvMembers } deriving stock (Eq, Show, Generic) @@ -197,10 +193,7 @@ mkConversation :: Maybe ReceiptMode -> Conversation mkConversation qid ty uid acc role name mems tid ms rm = - Conversation (ConversationMetadata qid ty uid acc role name tid ms rm) mems - -cnvQualifiedId :: Conversation -> Qualified ConvId -cnvQualifiedId = cnvmQualifiedId . cnvMetadata + Conversation qid (ConversationMetadata ty uid acc role name tid ms rm) mems cnvType :: Conversation -> ConvType cnvType = cnvmType . cnvMetadata @@ -232,7 +225,10 @@ instance ToSchema Conversation where "Conversation" (description ?~ "A conversation object as returned from the server") $ Conversation - <$> cnvMetadata .= conversationMetadataObjectSchema + <$> cnvQualifiedId .= field "qualified_id" schema + <* (qUnqualified . cnvQualifiedId) + .= optional (field "id" (deprecatedSchema "qualified_id" schema)) + <*> cnvMetadata .= conversationMetadataObjectSchema <*> cnvMembers .= field "members" schema modelConversation :: Doc.Model diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs index d23b8022f3..6c17eda72f 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs @@ -32,10 +32,10 @@ testObject_ConversationList_20Conversation_user_1 = ConversationList { convList = [ Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = RegularConv, + { cnvmType = RegularConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs index 0ea5ad8e86..5b819cdd47 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs @@ -34,10 +34,10 @@ domain = Domain "golden.example.com" testObject_Conversation_user_1 :: Conversation testObject_Conversation_user_1 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = One2OneConv, + { cnvmType = One2OneConv, cnvmCreator = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, @@ -67,10 +67,10 @@ testObject_Conversation_user_1 = testObject_Conversation_user_2 :: Conversation testObject_Conversation_user_2 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), - cnvmType = SelfConv, + { cnvmType = SelfConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [ InviteAccess, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs index 8ec156d909..6f5e8a6c28 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs @@ -142,10 +142,10 @@ testObject_Event_user_8 = (read "1864-05-29 19:31:31.226 UTC") ( EdConversation ( Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) (Domain "golden.example.com"), - cnvmType = RegularConv, + { cnvmType = RegularConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [InviteAccess, PrivateAccess, LinkAccess, InviteAccess, InviteAccess, InviteAccess, LinkAccess], diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs index f91466f0dc..534641eb82 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs @@ -29,10 +29,10 @@ testObject_ConversationsResponse_1 = conv1 :: Conversation conv1 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = One2OneConv, + { cnvmType = One2OneConv, cnvmCreator = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, @@ -62,10 +62,10 @@ conv1 = conv2 :: Conversation conv2 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), - cnvmType = SelfConv, + { cnvmType = SelfConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [ InviteAccess, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs index 1a095aaf33..c1751973c2 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs @@ -19,7 +19,7 @@ module Test.Wire.API.Golden.Manual.UserClientPrekeyMap where -import Data.Id (ClientId (ClientId, client), Id (Id)) +import Data.Id import qualified Data.UUID as UUID (fromString) import GHC.Exts (IsList (fromList)) import Imports diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index c0a51bd18b..024f27fb14 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -69,7 +69,7 @@ import Data.List.Split (chunksOf) import Data.Map.Strict (traverseWithKey) import qualified Data.Map.Strict as Map import Data.Misc (PlainTextPassword (..)) -import Data.Qualified (Qualified (..), partitionQualified, partitionRemoteOrLocalIds) +import Data.Qualified import qualified Data.Set as Set import Galley.Types (UserClients (..)) import Imports @@ -106,14 +106,14 @@ lookupPubClients qid@(Qualified uid domain) = do lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError AppIO (QualifiedUserMap (Set PubClient)) lookupPubClientsBulk qualifiedUids = do - domain <- viewFederationDomain - let (remoteUsers, localUsers) = partitionRemoteOrLocalIds domain qualifiedUids + loc <- qualifyLocal () + let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids remoteUserClientMap <- traverseWithKey (\domain' uids -> getUserClients domain' (GetUserClients uids)) - (partitionQualified remoteUsers) + (indexQualified (fmap qUntagged remoteUsers)) !>> ClientFederationError - localUserClientMap <- Map.singleton domain <$> lookupLocalPubClientsBulk localUsers + localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError AppIO (UserMap (Set PubClient)) diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index fbf217927c..6f4906622f 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -51,7 +51,6 @@ import qualified Data.LegalHold as LH import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range -import Data.Tagged import Galley.Types (ConvType (..), cnvType) import Imports import qualified System.Logger.Class as Log @@ -62,13 +61,13 @@ import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) ensureIsActivated :: Local UserId -> MaybeT AppIO () ensureIsActivated lusr = do - active <- lift $ Data.isActivated (lUnqualified lusr) + active <- lift $ Data.isActivated (tUnqualified lusr) guard active ensureNotSameTeam :: Local UserId -> Local UserId -> ConnectionM () ensureNotSameTeam self target = do - selfTeam <- lift $ Intra.getTeamId (lUnqualified self) - targetTeam <- lift $ Intra.getTeamId (lUnqualified target) + selfTeam <- lift $ Intra.getTeamId (tUnqualified self) + targetTeam <- lift $ Intra.getTeamId (tUnqualified target) when (isJust selfTeam && selfTeam == targetTeam) $ throwE ConnectSameBindingTeamUsers @@ -79,7 +78,7 @@ createConnection :: ConnectionM (ResponseForExistedCreated UserConnection) createConnection self con target = do -- basic checks: no need to distinguish between local and remote at this point - when (unTagged self == target) $ + when (qUntagged self == target) $ throwE (InvalidUser target) noteT ConnectNoIdentity $ ensureIsActivated self @@ -97,12 +96,12 @@ createConnectionToLocalUser :: Local UserId -> ConnectionM (ResponseForExistedCreated UserConnection) createConnectionToLocalUser self conn target = do - noteT (InvalidUser (unTagged target)) $ + noteT (InvalidUser (qUntagged target)) $ ensureIsActivated target - checkLegalholdPolicyConflict (lUnqualified self) (lUnqualified target) + checkLegalholdPolicyConflict (tUnqualified self) (tUnqualified target) ensureNotSameTeam self target - s2o <- lift $ Data.lookupConnection self (unTagged target) - o2s <- lift $ Data.lookupConnection target (unTagged self) + s2o <- lift $ Data.lookupConnection self (qUntagged target) + o2s <- lift $ Data.lookupConnection target (qUntagged self) case update <$> s2o <*> o2s of Just rs -> rs @@ -113,26 +112,26 @@ createConnectionToLocalUser self conn target = do insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError AppIO UserConnection insert s2o o2s = lift $ do Log.info $ - logConnection (lUnqualified self) (unTagged target) + logConnection (tUnqualified self) (qUntagged target) . msg (val "Creating connection") - qcnv <- Intra.createConnectConv (unTagged self) (unTagged target) Nothing (Just conn) - s2o' <- Data.insertConnection self (unTagged target) SentWithHistory qcnv - o2s' <- Data.insertConnection target (unTagged self) PendingWithHistory qcnv + qcnv <- Intra.createConnectConv (qUntagged self) (qUntagged target) Nothing (Just conn) + s2o' <- Data.insertConnection self (qUntagged target) SentWithHistory qcnv + o2s' <- Data.insertConnection target (qUntagged self) PendingWithHistory qcnv e2o <- ConnectionUpdated o2s' (ucStatus <$> o2s) - <$> Data.lookupName (lUnqualified self) + <$> Data.lookupName (tUnqualified self) let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing - mapM_ (Intra.onConnectionEvent (lUnqualified self) (Just conn)) [e2o, e2s] + mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return s2o' update :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) update s2o o2s = case (ucStatus s2o, ucStatus o2s) of - (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) - (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) + (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) (Accepted, Accepted) -> return $ Existed s2o (Accepted, Blocked) -> return $ Existed s2o (Sent, Blocked) -> return $ Existed s2o - (Blocked, _) -> throwE $ InvalidTransition (lUnqualified self) + (Blocked, _) -> throwE $ InvalidTransition (tUnqualified self) (_, Blocked) -> change s2o SentWithHistory (_, Sent) -> accept s2o o2s (_, Accepted) -> accept s2o o2s @@ -145,7 +144,7 @@ createConnectionToLocalUser self conn target = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") cnv <- lift $ for (ucConvId s2o) $ Intra.acceptConnectConv self (Just conn) s2o' <- lift $ Data.updateConnection s2o AcceptedWithHistory @@ -157,9 +156,9 @@ createConnectionToLocalUser self conn target = do e2o <- lift $ ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (lUnqualified self) + <$> Data.lookupName (tUnqualified self) let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing - lift $ mapM_ (Intra.onConnectionEvent (lUnqualified self) (Just conn)) [e2o, e2s] + lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return $ Existed s2o' resend :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) @@ -167,7 +166,7 @@ createConnectionToLocalUser self conn target = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Resending connection request") s2o' <- insert (Just s2o) (Just o2s) return $ Existed s2o' @@ -235,9 +234,9 @@ updateConnectionToLocalUser self other newStatus conn = do o2s <- localConnection other self s2o' <- case (ucStatus s2o, ucStatus o2s, newStatus) of -- missing legalhold consent: call 'updateConectionInternal' instead. - (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (lUnqualified self) - (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (lUnqualified self) - (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (lUnqualified self) + (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) -- Pending -> {Blocked, Ignored, Accepted} (Pending, _, Blocked) -> block s2o (Pending, _, Ignored) -> change s2o Ignored @@ -273,18 +272,18 @@ updateConnectionToLocalUser self other newStatus conn = do -- no change (old, _, new) | old == new -> return Nothing -- invalid - _ -> throwE $ InvalidTransition (lUnqualified self) + _ -> throwE $ InvalidTransition (tUnqualified self) let s2oUserConn = s2o' lift . for_ s2oUserConn $ \c -> let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing - in Intra.onConnectionEvent (lUnqualified self) conn e2s + in Intra.onConnectionEvent (tUnqualified self) conn e2s return s2oUserConn where accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) accept s2o o2s = do checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") cnv <- lift $ traverse (Intra.acceptConnectConv self conn) (ucConvId s2o) -- Note: The check for @Pending@ accounts for situations in which both @@ -298,14 +297,14 @@ updateConnectionToLocalUser self other newStatus conn = do else Data.updateConnection o2s BlockedWithHistory e2o <- ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (lUnqualified self) - Intra.onConnectionEvent (lUnqualified self) conn e2o + <$> Data.lookupName (tUnqualified self) + Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o AcceptedWithHistory block :: UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) block s2o = lift $ do Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Blocking connection") traverse_ (Intra.blockConv self conn) (ucConvId s2o) Just <$> Data.updateConnection s2o BlockedWithHistory @@ -316,7 +315,7 @@ updateConnectionToLocalUser self other newStatus conn = do when (new `elem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Unblocking connection") cnv <- lift $ traverse (Intra.unblockConv self conn) (ucConvId s2o) when (ucStatus o2s == Sent && new == Accepted) . lift $ do @@ -326,21 +325,21 @@ updateConnectionToLocalUser self other newStatus conn = do else Data.updateConnection o2s BlockedWithHistory e2o :: ConnectionEvent <- ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (lUnqualified self) + <$> Data.lookupName (tUnqualified self) -- TODO: is this correct? shouldnt o2s be sent to other? - Intra.onConnectionEvent (lUnqualified self) conn e2o + Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) cancel s2o o2s = do Log.info $ - logLocalConnection (lUnqualified self) (qUnqualified (ucTo s2o)) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Cancelling connection") lfrom <- qualifyLocal (ucFrom s2o) lift $ traverse_ (Intra.blockConv lfrom conn) (ucConvId s2o) o2s' <- lift $ Data.updateConnection o2s CancelledWithHistory let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing - lift $ Intra.onConnectionEvent (lUnqualified self) conn e2o + lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled change :: UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) @@ -353,8 +352,8 @@ localConnection :: Local UserId -> ExceptT ConnectionError AppIO UserConnection localConnection la lb = do - lift (Data.lookupConnection la (unTagged lb)) - >>= tryJust (NotConnected (lUnqualified la) (unTagged lb)) + lift (Data.lookupConnection la (qUntagged lb)) + >>= tryJust (NotConnected (tUnqualified la) (qUntagged lb)) mkRelationWithHistory :: HasCallStack => Relation -> Relation -> RelationWithHistory mkRelationWithHistory oldRel = \case @@ -388,7 +387,7 @@ updateConnectionInternal = \case blockForMissingLegalholdConsent self others = do for_ others $ \(qualifyAs self -> other) -> do Log.info $ - logConnection (lUnqualified self) (unTagged other) + logConnection (tUnqualified self) (qUntagged other) . msg (val "Blocking connection (legalhold device present, but missing consent)") s2o <- localConnection self other @@ -398,7 +397,7 @@ updateConnectionInternal = \case traverse_ (Intra.blockConv lfrom Nothing) (ucConvId uconn) uconn' <- Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing - Intra.onConnectionEvent (lUnqualified self) Nothing ev + Intra.onConnectionEvent (tUnqualified self) Nothing ev removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError AppIO () removeLHBlocksInvolving self = @@ -435,7 +434,7 @@ updateConnectionInternal = \case void . lift . for (ucConvId uconn) $ Intra.unblockConv lfrom Nothing uconnRevRel :: RelationWithHistory <- relationWithHistory lfrom (ucTo uconnRev) uconnRev' <- lift $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel) - connName <- lift $ Data.lookupName (lUnqualified lfrom) + connName <- lift $ Data.lookupName (tUnqualified lfrom) let connEvent = ConnectionUpdated { ucConn = uconnRev', @@ -447,7 +446,7 @@ updateConnectionInternal = \case relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError AppIO RelationWithHistory relationWithHistory self target = lift (Data.lookupRelationWithHistory self target) - >>= tryJust (NotConnected (lUnqualified self) target) + >>= tryJust (NotConnected (tUnqualified self) target) undoRelationHistory :: RelationWithHistory -> RelationWithHistory undoRelationHistory = \case diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 12213cfbd1..387b04c617 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -36,7 +36,6 @@ import Control.Error.Util ((??)) import Control.Monad.Trans.Except (runExceptT, throwE) import Data.Id as Id import Data.Qualified -import Data.Tagged import Data.UUID.V4 import Imports import Network.Wai.Utilities.Error @@ -112,7 +111,7 @@ updateOne2OneConv :: updateOne2OneConv _ _ _ _ _ = do -- FUTUREWORK: use galley internal API to update 1-1 conversation and retrieve ID uid <- liftIO nextRandom - unTagged <$> qualifyLocal (Id uid) + qUntagged <$> qualifyLocal (Id uid) -- | Perform a state transition on a connection, handle conversation updates and -- push events. @@ -131,7 +130,7 @@ transitionTo :: transitionTo self _ _ Nothing Nothing = -- This can only happen if someone tries to ignore as a first action on a -- connection. This shouldn't be possible. - throwE (InvalidTransition (lUnqualified self)) + throwE (InvalidTransition (tUnqualified self)) transitionTo self mzcon other Nothing (Just rel) = lift $ do -- update 1-1 connection qcnv <- updateOne2OneConv self mzcon other Nothing rel @@ -140,7 +139,7 @@ transitionTo self mzcon other Nothing (Just rel) = lift $ do connection <- Data.insertConnection self - (unTagged other) + (qUntagged other) (relationWithHistory rel) qcnv @@ -163,7 +162,7 @@ transitionTo self mzcon other (Just connection) (Just rel) = lift $ do pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> AppIO () pushEvent self mzcon connection = do let event = ConnectionUpdated connection Nothing Nothing - Intra.onConnectionEvent (lUnqualified self) mzcon event + Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: Local UserId -> @@ -180,7 +179,7 @@ performLocalAction self mzcon other mconnection action = do response <- sendConnectionAction self other ra !>> ConnectFederationError case (response :: NewConnectionResponse) of NewConnectionResponseOk reaction -> pure reaction - NewConnectionResponseUserNotActivated -> throwE (InvalidUser (unTagged other)) + NewConnectionResponseUserNotActivated -> throwE (InvalidUser (qUntagged other)) pure $ fromMaybe rel1 $ do reactionAction <- (mreaction :: Maybe RemoteConnectionAction) @@ -235,7 +234,7 @@ createConnectionToRemoteUser :: Remote UserId -> ConnectionM (ResponseForExistedCreated UserConnection) createConnectionToRemoteUser self zcon other = do - mconnection <- lift $ Data.lookupConnection self (unTagged other) + mconnection <- lift $ Data.lookupConnection self (qUntagged other) fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: @@ -245,10 +244,10 @@ updateConnectionToRemoteUser :: Maybe ConnId -> ConnectionM (Maybe UserConnection) updateConnectionToRemoteUser self other rel1 zcon = do - mconnection <- lift $ Data.lookupConnection self (unTagged other) + mconnection <- lift $ Data.lookupConnection self (qUntagged other) action <- actionForTransition rel1 - ?? InvalidTransition (lUnqualified self) + ?? InvalidTransition (tUnqualified self) (conn, wasUpdated) <- performLocalAction self zcon other mconnection action pure $ guard wasUpdated $> extract conn where diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index bc054986ca..0f1f7b5b10 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -29,7 +29,7 @@ import Control.Error (noteT) import Control.Lens (view) import Control.Monad.Trans.Except import Data.Id (UserId) -import Data.Qualified (Local, lUnqualified) +import Data.Qualified (Local, tUnqualified) import Imports import Wire.API.Connection (Relation (..)) @@ -38,7 +38,7 @@ type ConnectionM = ExceptT ConnectionError AppIO -- Helpers checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () -checkLimit u = noteT (TooManyConnections (lUnqualified u)) $ do +checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do n <- lift $ Data.countConnections u [Accepted, Sent] l <- setUserMaxConnections <$> view settings guard (n < l) diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index a397357e3b..2e9ea4ac12 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -33,7 +33,6 @@ import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, UserId) import Data.Qualified -import Data.Tagged (Tagged (unTagged)) import Imports import Network.Wai.Utilities.Error ((!>>)) import Servant (ServerT) @@ -70,8 +69,8 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do if active then do self <- qualifyLocal ncrTo - let other = toRemote $ Qualified ncrFrom originDomain - mconnection <- lift $ Data.lookupConnection self (unTagged other) + let other = toRemoteUnsafe originDomain ncrFrom + mconnection <- lift $ Data.lookupConnection self (qUntagged other) maction <- lift $ performRemoteAction self other mconnection ncrAction pure $ NewConnectionResponseOk maction else pure NewConnectionResponseUserNotActivated diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 057006c2b8..23087994fc 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -70,7 +70,7 @@ import Data.Handle (Handle, parseHandle) import Data.Id as Id import qualified Data.Map.Strict as Map import Data.Misc (IpAddr (..)) -import Data.Qualified (Local, Qualified (..), partitionRemoteOrLocalIds) +import Data.Qualified import Data.Range import Data.String.Interpolate as QQ import qualified Data.Swagger as S @@ -936,8 +936,8 @@ listUsersByIdsOrHandles self q = do Public.ListUsersByIds us -> byIds us Public.ListUsersByHandles hs -> do - domain <- viewFederationDomain - let (_remoteHandles, localHandles) = partitionRemoteOrLocalIds domain (fromRange hs) + loc <- qualifyLocal () + let (localHandles, _) = partitionQualified loc (fromRange hs) us <- getIds localHandles Handle.filterHandleResults self =<< byIds us case foundUsers of @@ -1088,7 +1088,7 @@ createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> H createConnectionUnqualified self conn cr = do lself <- qualifyLocal self target <- qualifyLocal (Public.crUser cr) - API.createConnection lself conn (unTagged target) !>> connError + API.createConnection lself conn (qUntagged target) !>> connError createConnection :: UserId -> ConnId -> Qualified UserId -> Handler (Public.ResponseForExistedCreated Public.UserConnection) createConnection self conn target = do @@ -1098,7 +1098,7 @@ createConnection self conn target = do updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) updateLocalConnection self conn other update = do lother <- qualifyLocal other - updateConnection self conn (unTagged lother) update + updateConnection self conn (qUntagged lother) update updateConnection :: UserId -> ConnId -> Qualified UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) updateConnection self conn other update = do @@ -1157,7 +1157,7 @@ listConnections uid Public.GetMultiTablePageRequest {..} = do getLocalConnection :: UserId -> UserId -> Handler (Maybe Public.UserConnection) getLocalConnection self other = do lother <- qualifyLocal other - getConnection self (unTagged lother) + getConnection self (qUntagged lother) getConnection :: UserId -> Qualified UserId -> Handler (Maybe Public.UserConnection) getConnection self other = do diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e39aba706a..c2741ef906 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -144,7 +144,7 @@ import Data.List1 (List1) import qualified Data.Map.Strict as Map import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) -import Data.Qualified (Qualified, partitionQualified) +import Data.Qualified (Qualified, indexQualified) import Data.Time.Clock (addUTCTime, diffUTCTime) import Data.UUID.V4 (nextRandom) import qualified Galley.Types.Teams as Team @@ -1140,7 +1140,7 @@ lookupProfiles :: ExceptT FederationError AppIO [UserProfile] lookupProfiles self others = do localDomain <- viewFederationDomain - let userMap = partitionQualified others + let userMap = indexQualified others -- FUTUREWORK(federation): parallelise federator requests here fold <$> traverse (uncurry (getProfiles localDomain)) (Map.assocs userMap) where diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 65a2e3020f..0089940425 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -107,7 +107,7 @@ import Data.List1 (List1, list1) import Data.Metrics (Metrics) import qualified Data.Metrics.Middleware as Metrics import Data.Misc -import Data.Qualified (Local, Qualified (..), toLocal) +import Data.Qualified import Data.Text (unpack) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) @@ -540,8 +540,8 @@ readTurnList = Text.readFile >=> return . fn . mapMaybe fromByteString . fmap Te -------------------------------------------------------------------------------- -- Federation -viewFederationDomain :: MonadReader Env m => m (Domain) +viewFederationDomain :: MonadReader Env m => m Domain viewFederationDomain = view (settings . Opt.federationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) -qualifyLocal a = fmap (toLocal . Qualified a) viewFederationDomain +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index dbd7db7d91..342704fc71 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -60,7 +60,6 @@ import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified import Data.Range -import Data.Tagged import Data.Time (getCurrentTime) import Imports hiding (local) import UnliftIO.Async (pooledMapConcurrentlyN_) @@ -74,16 +73,16 @@ insertConnection :: AppIO UserConnection insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (lUnqualified -> ltarget) = + let local (tUnqualified -> ltarget) = write connectionInsert $ - params Quorum (lUnqualified self, ltarget, rel, now, cnv) - let remote (unTagged -> Qualified rtarget domain) = + params Quorum (tUnqualified self, ltarget, rel, now, cnv) + let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionInsert $ - params Quorum (lUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + params Quorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) retry x5 $ foldQualified self local remote target pure $ UserConnection - { ucFrom = lUnqualified self, + { ucFrom = tUnqualified self, ucTo = target, ucStatus = relationDropHistory rel, ucLastUpdate = now, @@ -103,32 +102,32 @@ updateConnection c status = do updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> AppIO UTCTimeMillis updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - let local (lUnqualified -> ltarget) = + let local (tUnqualified -> ltarget) = write connectionUpdate $ - params Quorum (status, now, lUnqualified self, ltarget) - let remote (unTagged -> Qualified rtarget domain) = + params Quorum (status, now, tUnqualified self, ltarget) + let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionUpdate $ - params Quorum (status, now, lUnqualified self, domain, rtarget) + params Quorum (status, now, tUnqualified self, domain, rtarget) retry x5 $ foldQualified self local remote target pure now -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) lookupConnection self target = runMaybeT $ do - let local (lUnqualified -> ltarget) = do + let local (tUnqualified -> ltarget) = do (_, _, rel, time, mcnv) <- MaybeT . query1 connectionSelect $ - params Quorum (lUnqualified self, ltarget) - pure (rel, time, fmap (unTagged . qualifyAs self) mcnv) - let remote (unTagged -> Qualified rtarget domain) = do + params Quorum (tUnqualified self, ltarget) + pure (rel, time, fmap (qUntagged . qualifyAs self) mcnv) + let remote (qUntagged -> Qualified rtarget domain) = do (rel, time, cdomain, cnv) <- MaybeT . query1 remoteConnectionSelectFrom $ - params Quorum (lUnqualified self, domain, rtarget) + params Quorum (tUnqualified self, domain, rtarget) pure (rel, time, Just (Qualified cnv cdomain)) (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target pure $ UserConnection - { ucFrom = lUnqualified self, + { ucFrom = tUnqualified self, ucTo = target, ucStatus = relationDropHistory rel, ucLastUpdate = time, @@ -143,10 +142,10 @@ lookupRelationWithHistory :: Qualified UserId -> AppIO (Maybe RelationWithHistory) lookupRelationWithHistory self target = do - let local (lUnqualified -> ltarget) = - query1 relationSelect (params Quorum (lUnqualified self, ltarget)) - let remote (unTagged -> Qualified rtarget domain) = - query1 remoteRelationSelect (params Quorum (lUnqualified self, domain, rtarget)) + let local (tUnqualified -> ltarget) = + query1 relationSelect (params Quorum (tUnqualified self, ltarget)) + let remote (qUntagged -> Qualified rtarget domain) = + query1 remoteRelationSelect (params Quorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation @@ -161,10 +160,10 @@ lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of Just u -> retry x1 $ - paginate connectionsSelectFrom (paramsP Quorum (lUnqualified lfrom, u) (size + 1)) + paginate connectionsSelectFrom (paramsP Quorum (tUnqualified lfrom, u) (size + 1)) Nothing -> retry x1 $ - paginate connectionsSelect (paramsP Quorum (Identity (lUnqualified lfrom)) (size + 1)) + paginate connectionsSelect (paramsP Quorum (Identity (tUnqualified lfrom)) (size + 1)) where toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim trim p = p {result = take (fromIntegral size) (result p)} @@ -178,7 +177,7 @@ lookupLocalConnectionsPage :: Range 1 1000 Int32 -> m (PageWithState UserConnection) lookupLocalConnectionsPage self pagingState (fromRange -> size) = - fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (lUnqualified self)) size pagingState) + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) -- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. lookupRemoteConnectionsPage :: @@ -191,7 +190,7 @@ lookupRemoteConnectionsPage self pagingState size = fmap (toRemoteUserConnection self) <$> paginateWithState remoteConnectionSelect - (paramsPagingState Quorum (Identity (lUnqualified self)) size pagingState) + (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] @@ -221,8 +220,8 @@ lookupContactListWithRelation u = -- Note: The count is eventually consistent. countConnections :: Local UserId -> [Relation] -> AppIO Int64 countConnections u r = do - rels <- retry x1 . query selectStatus $ params One (Identity (lUnqualified u)) - relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (lUnqualified u)) + rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) + relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) return $ foldl' count 0 rels + foldl' count 0 relsRemote where @@ -309,14 +308,14 @@ toLocalUserConnection :: (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> UserConnection toLocalUserConnection loc (l, r, relationDropHistory -> rel, time, cid) = - UserConnection l (unTagged (qualifyAs loc r)) rel time (fmap (unTagged . qualifyAs loc) cid) + UserConnection l (qUntagged (qualifyAs loc r)) rel time (fmap (qUntagged . qualifyAs loc) cid) toRemoteUserConnection :: Local UserId -> (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> UserConnection toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, cid) = - UserConnection (lUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) + UserConnection (tUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 78bd55a573..002d3921dc 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -31,7 +31,6 @@ import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) import Data.Qualified -import Data.Tagged import qualified Data.Text as T import Imports import qualified System.Logger.Class as Log @@ -91,7 +90,7 @@ sendConnectionAction :: Remote UserId -> RemoteConnectionAction -> FederationAppIO NewConnectionResponse -sendConnectionAction self (unTagged -> other) action = do - let req = NewConnectionRequest (lUnqualified self) (qUnqualified other) action +sendConnectionAction self (qUntagged -> other) action = do + let req = NewConnectionRequest (tUnqualified self) (qUnqualified other) action Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" - executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (lDomain self) req + executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (tDomain self) req diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 28472c4779..afac8627dd 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -92,7 +92,6 @@ import Data.List1 (List1, list1, singleton) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import Galley.Types (Connect (..), Conversation) import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) @@ -543,7 +542,7 @@ createLocalConnectConv :: AppIO ConvId createLocalConnectConv from to cname conn = do debug $ - logConnection (lUnqualified from) (unTagged to) + logConnection (tUnqualified from) (qUntagged to) . remote "galley" . msg (val "Creating connect conversation") r <- galleyRequest POST req @@ -553,10 +552,10 @@ createLocalConnectConv from to cname conn = do where req = path "/i/conversations/connect" - . zUser (lUnqualified from) + . zUser (tUnqualified from) . maybe id (header "Z-Connection" . fromConnId) conn . contentJson - . lbytes (encode $ Connect (lUnqualified to) Nothing cname Nothing) + . lbytes (encode $ Connect (tUnqualified to) Nothing cname Nothing) . expect2xx createConnectConv :: @@ -568,7 +567,7 @@ createConnectConv :: createConnectConv from to cname conn = do lfrom <- ensureLocal from lto <- ensureLocal to - unTagged . qualifyAs lfrom + qUntagged . qualifyAs lfrom <$> createLocalConnectConv lfrom lto cname conn where ensureLocal :: Qualified a -> AppIO (Local a) @@ -587,7 +586,7 @@ acceptLocalConnectConv from conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "accept", "v2"] - . zUser (lUnqualified from) + . zUser (tUnqualified from) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx @@ -595,7 +594,7 @@ acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO C acceptConnectConv from conn = foldQualified from - (acceptLocalConnectConv from conn . lUnqualified) + (acceptLocalConnectConv from conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.blockConvH'. @@ -609,7 +608,7 @@ blockLocalConv lusr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "block"] - . zUser (lUnqualified lusr) + . zUser (tUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx @@ -617,7 +616,7 @@ blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO () blockConv lusr conn = foldQualified lusr - (blockLocalConv lusr conn . lUnqualified) + (blockLocalConv lusr conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.unblockConvH'. @@ -631,7 +630,7 @@ unblockLocalConv lusr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "unblock"] - . zUser (lUnqualified lusr) + . zUser (tUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx @@ -639,7 +638,7 @@ unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Convers unblockConv luid conn = foldQualified luid - (unblockLocalConv luid conn . lUnqualified) + (unblockLocalConv luid conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.getConversationH'. diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index fc9f39ccf1..867bc7c690 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -215,7 +215,7 @@ testClaimMultiPrekeyBundleSuccess brig1 brig2 = do mkClientMap :: [ClientPrekey] -> Map ClientId (Maybe Prekey) mkClientMap = Map.fromList . map (prekeyClient &&& Just . prekeyData) qmap :: Ord a => [(Qualified a, b)] -> Map Domain (Map a b) - qmap = fmap Map.fromList . partitionQualified . map (sequenceAOf _1) + qmap = fmap Map.fromList . indexQualified . map (sequenceAOf _1) c1 <- generateClientPrekeys brig1 prekeys1 c2 <- generateClientPrekeys brig2 prekeys2 let uc = diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 9c1f82c351..b5581f1b6c 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -32,7 +32,6 @@ import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import Data.Time import qualified Data.UUID.Tagged as U import Galley.API.Error @@ -101,7 +100,7 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do qualifiedUserIds = newConvQualifiedUsers body allUsers = toUserList lusr $ - map (unTagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + map (qUntagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds checkedUsers <- checkedConvSize allUsers ensureConnected zusr (ulLocals allUsers) checkRemoteUsersExist (ulRemotes allUsers) @@ -130,7 +129,7 @@ createTeamGroupConv zusr zcon tinfo body = do qualifiedUserIds = newConvQualifiedUsers body allUsers = toUserList lusr $ - map (unTagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + map (qUntagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds convTeam = cnvTeamId tinfo zusrMembership <- Data.teamMember convTeam zusr @@ -238,7 +237,7 @@ createConnectConversation usr conn j = do c <- Data.createConnectConversation lusr x y n now <- liftIO getCurrentTime let lcid = qualifyAs lusr (Data.convId c) - e = Event ConvConnect (unTagged lcid) (unTagged lusr) now (EdConnect j) + e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) notifyCreatedConversation Nothing usr conn c for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> push1 $ diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 512077e7de..c7476ccfd7 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -27,9 +27,8 @@ import Data.Json.Util (Base64ByteString (..)) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), toRemote) +import Data.Qualified (Qualified (..), qUntagged, toRemoteUnsafe) import qualified Data.Set as Set -import Data.Tagged import qualified Data.Text.Lazy as LT import Galley.API.Error (invalidPayload) import qualified Galley.API.Mapping as Mapping @@ -100,11 +99,10 @@ onConversationCreated domain rc = do getConversations :: Domain -> GetConversationsRequest -> Galley GetConversationsResponse getConversations domain (GetConversationsRequest uid cids) = do - let ruid = toRemote $ Qualified uid domain + let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain GetConversationsResponse - . catMaybes - . map (Mapping.conversationToRemote localDomain ruid) + . mapMaybe (Mapping.conversationToRemote localDomain ruid) <$> Data.localConversations cids getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] @@ -184,8 +182,8 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: error handling for missing / mismatched clients onMessageSent :: Domain -> RemoteMessage ConvId -> Galley () onMessageSent domain rmUnqualified = do - let rm = fmap (Tagged . (`Qualified` domain)) rmUnqualified - let convId = unTagged $ rmConversation rm + let rm = fmap (toRemoteUnsafe domain) rmUnqualified + convId = qUntagged $ rmConversation rm msgMetadata = MessageMetadata { mmNativePush = rmPush rm, diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2f51149b5b..65b8fd7a92 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -32,7 +32,7 @@ import Control.Monad.Catch (MonadCatch) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) -import Data.Qualified (Local, Qualified (..), Remote, lUnqualified, partitionRemoteOrLocalIds') +import Data.Qualified import Data.Range import Data.String.Conversions (cs) import Data.Time @@ -453,13 +453,12 @@ rmUser user conn = do where goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley () goConvPages lusr range page = do - localDomain <- viewFederationDomain - let (remoteConvs, localConvs) = partitionRemoteOrLocalIds' localDomain . mtpResults $ page + let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs leaveRemoteConversations lusr remoteConvs when (mtpHasMore page) $ do let nextState = mtpPagingState page - usr = lUnqualified lusr + usr = tUnqualified lusr nextQuery = GetPaginatedConversationIds (Just nextState) range newCids <- Query.conversationIdsPageFrom usr nextQuery goConvPages lusr range newCids @@ -500,7 +499,7 @@ rmUser user conn = do leaveRemoteConversations :: Foldable t => Local UserId -> t (Remote ConvId) -> Galley () leaveRemoteConversations lusr cids = for_ cids $ \cid -> - Update.removeMemberFromRemoteConv cid lusr Nothing (unTagged lusr) + Update.removeMemberFromRemoteConv cid lusr Nothing (qUntagged lusr) deleteLoop :: Galley () deleteLoop = do diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index d4ea7c3ed7..1755eec74c 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -46,8 +46,8 @@ import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Split (chunksOf) import Data.Misc import Data.Proxy (Proxy (Proxy)) +import Data.Qualified (qUntagged) import Data.Range (toRange) -import Data.Tagged import Galley.API.Error import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) @@ -510,8 +510,8 @@ handleGroupConvPolicyConflicts uid hypotheticalLHStatus = then do for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do lusr <- qualifyLocal (lmId memberNoConsent) - removeMemberFromLocalConv lcnv lusr Nothing (unTagged lusr) + removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) else do for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do lusr <- qualifyLocal (lmId legalholder) - removeMemberFromLocalConv lcnv lusr Nothing (unTagged lusr) + removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index e99921917e..c9da03d9c9 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -74,7 +74,8 @@ conversationViewMaybe localDomain uid conv = do <> map remoteMemberToOther rothers pure $ Conversation - (Data.convMetadata localDomain conv) + (Qualified (convId conv) localDomain) + (Data.convMetadata conv) (ConvMembers self others) -- | View for a local user of a remote conversation. @@ -85,9 +86,9 @@ conversationViewMaybe localDomain uid conv = do remoteConversationView :: UserId -> MemberStatus -> - RemoteConversation -> + Remote RemoteConversation -> Maybe Conversation -remoteConversationView uid status rconv = do +remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do let mems = rcnvMembers rconv others = rcmOthers mems self = @@ -98,7 +99,7 @@ remoteConversationView uid status rconv = do lmStatus = status, lmConvRoleName = rcmSelfRole mems } - pure $ Conversation (rcnvMetadata rconv) (ConvMembers self others) + pure $ Conversation (Qualified (rcnvId rconv) rDomain) (rcnvMetadata rconv) (ConvMembers self others) -- | Convert a local conversation to a structure to be returned to a remote -- backend. @@ -118,7 +119,8 @@ conversationToRemote localDomain ruid conv = do <> map remoteMemberToOther rothers pure $ RemoteConversation - { rcnvMetadata = Data.convMetadata localDomain conv, + { rcnvId = Data.convId conv, + rcnvMetadata = Data.convMetadata conv, rcnvMembers = RemoteConvMembers { rcmSelfRole = selfRole, diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index ab744e355d..8429863851 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -17,10 +17,9 @@ import Data.Json.Util import Data.List1 (singleton) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), partitionRemote) +import Data.Qualified import qualified Data.Set as Set import Data.Set.Lens -import Data.Tagged (unTagged) import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util @@ -183,13 +182,13 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = getRemoteClients :: [RemoteMember] -> Galley (Map (Domain, UserId) (Set ClientId)) getRemoteClients remoteMembers = do fmap mconcat -- concatenating maps is correct here, because their sets of keys are disjoint - . pooledMapConcurrentlyN 8 (uncurry getRemoteClientsFromDomain) - . partitionRemote + . pooledMapConcurrentlyN 8 getRemoteClientsFromDomain + . indexRemote . map rmId $ remoteMembers where - getRemoteClientsFromDomain :: Domain -> [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) - getRemoteClientsFromDomain domain uids = do + getRemoteClientsFromDomain :: Remote [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) + getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = do let rpc = FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> runFederatedBrig domain rpc @@ -231,7 +230,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do members :: Set (Qualified UserId) members = Set.map (`Qualified` localDomain) (Map.keysSet localMemberMap) - <> Set.fromList (map (unTagged . rmId) remoteMembers) + <> Set.fromList (map (qUntagged . rmId) remoteMembers) isInternal <- view $ options . optSettings . setIntraListing -- check if the sender is part of the conversation diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index ab44749533..7212b12346 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -34,6 +34,7 @@ module Galley.API.Query where import qualified Cassandra as C +import Control.Lens (sequenceAOf) import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS @@ -43,10 +44,9 @@ import Data.Domain (Domain) import Data.Id as Id import qualified Data.Map as Map import Data.Proxy -import Data.Qualified (Qualified (..), Remote, partitionRemote, partitionRemoteOrLocalIds', toRemote) +import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged (unTagged) import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util @@ -100,10 +100,12 @@ getUnqualifiedConversation zusr cnv = do getConversation :: UserId -> Qualified ConvId -> Galley Public.Conversation getConversation zusr cnv = do - localDomain <- viewFederationDomain - if qDomain cnv == localDomain - then getUnqualifiedConversation zusr (qUnqualified cnv) - else getRemoteConversation (toRemote cnv) + lusr <- qualifyLocal zusr + foldQualified + lusr + (getUnqualifiedConversation zusr . tUnqualified) + getRemoteConversation + cnv where getRemoteConversation :: Remote ConvId -> Galley Public.Conversation getRemoteConversation remoteConvId = do @@ -137,9 +139,9 @@ fgcError :: FailedGetConversation -> Wai.Error fgcError (FailedGetConversation _ r) = fgcrError r failedGetConversationRemotely :: - [Qualified ConvId] -> FederationError -> FailedGetConversation + [Remote ConvId] -> FederationError -> FailedGetConversation failedGetConversationRemotely qconvs = - FailedGetConversation qconvs . FailedGetConversationRemotely + FailedGetConversation (map qUntagged qconvs) . FailedGetConversationRemotely failedGetConversationLocally :: [Qualified ConvId] -> FailedGetConversation @@ -162,36 +164,37 @@ getRemoteConversationsWithFailures zusr convs = do -- get self member statuses from the database statusMap <- Data.remoteConversationStatus zusr convs - let remoteView rconv = + let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation + remoteView rconv = Mapping.remoteConversationView zusr ( Map.findWithDefault defMemberStatus - (toRemote (cnvmQualifiedId (FederatedGalley.rcnvMetadata rconv))) + (fmap FederatedGalley.rcnvId rconv) statusMap ) rconv (locallyFound, locallyNotFound) = partition (flip Map.member statusMap) convs localFailures | null locallyNotFound = [] - | otherwise = [failedGetConversationLocally (map unTagged locallyNotFound)] + | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends fmap (bimap (localFailures <>) concat . partitionEithers) - . pooledForConcurrentlyN 8 (partitionRemote locallyFound) - $ \(domain, someConvs) -> do - let req = FederatedGalley.GetConversationsRequest zusr someConvs + . pooledForConcurrentlyN 8 (indexRemote locallyFound) + $ \someConvs -> do + let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes localDomain req - handleFailures (map (flip Qualified domain) someConvs) $ do - rconvs <- gcresConvs <$> executeFederated domain rpc - pure $ catMaybes (map remoteView rconvs) + handleFailures (sequenceAOf tUnqualifiedL someConvs) $ do + rconvs <- gcresConvs <$> executeFederated (tDomain someConvs) rpc + pure $ mapMaybe (remoteView . qualifyAs someConvs) rconvs where handleFailures :: - [Qualified ConvId] -> + [Remote ConvId] -> ExceptT FederationError Galley a -> Galley (Either FailedGetConversation a) - handleFailures qconvs action = runExceptT - . withExceptT (failedGetConversationRemotely qconvs) + handleFailures rconvs action = runExceptT + . withExceptT (failedGetConversationRemotely rconvs) . catchE action $ \e -> do lift . Logger.warn $ @@ -289,9 +292,9 @@ getConversationsInternal user mids mstart msize = do listConversations :: UserId -> Public.ListConversations -> Galley Public.ConversationsResponse listConversations user (Public.ListConversations ids) = do - localDomain <- viewFederationDomain + luser <- qualifyLocal user - let (remoteIds, localIds) = partitionRemoteOrLocalIds' localDomain (fromRange ids) + let (localIds, remoteIds) = partitionQualified luser (fromRange ids) (foundLocalIds, notFoundLocalIds) <- foundsAndNotFounds (Data.localConversationIdsOf user) localIds localInternalConversations <- @@ -304,7 +307,7 @@ listConversations user (Public.ListConversations ids) = do let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures failedConvs = failedConvsLocally <> failedConvsRemotely fetchedOrFailedRemoteIds = Set.fromList $ map Public.cnvQualifiedId remoteConversations <> failedConvs - remoteNotFoundRemoteIds = filter (`Set.notMember` fetchedOrFailedRemoteIds) $ map unTagged remoteIds + remoteNotFoundRemoteIds = filter (`Set.notMember` fetchedOrFailedRemoteIds) $ map qUntagged remoteIds unless (null remoteNotFoundRemoteIds) $ -- FUTUREWORK: This implies that the backends are out of sync. Maybe the -- current user should be considered removed from this conversation at this @@ -320,7 +323,7 @@ listConversations user (Public.ListConversations ids) = do crNotFound = failedConvsLocally <> remoteNotFoundRemoteIds - <> map (`Qualified` localDomain) notFoundLocalIds, + <> map (qUntagged . qualifyAs luser) notFoundLocalIds, crFailed = failedConvsRemotely } where diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 59bf3e4f29..7b1976d83d 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -81,7 +81,6 @@ import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import Data.Time import Galley.API.Error import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) @@ -211,7 +210,7 @@ updateLocalConversationAccess :: Galley (UpdateResult Event) updateLocalConversationAccess lcnv lusr con target = getUpdateResult - . updateLocalConversation lcnv (unTagged lusr) (Just con) + . updateLocalConversation lcnv (qUntagged lusr) (Just con) . ConversationActionAccessUpdate $ target @@ -238,7 +237,7 @@ performAccessUpdateAction qusr conv target = do && CodeAccess `notElem` cupAccess target ) $ lift $ do - key <- mkKey (lUnqualified lcnv) + key <- mkKey (tUnqualified lcnv) Data.deleteCode key ReusableCode -- Depending on a variety of things, some bots and users have to be -- removed from the conversation. We keep track of them using 'State'. @@ -266,18 +265,18 @@ performAccessUpdateAction qusr conv target = do botsL .= [] _ -> return () -- Update Cassandra - lift $ Data.updateConversationAccess (lUnqualified lcnv) target + lift $ Data.updateConversationAccess (tUnqualified lcnv) target -- Remove users and bots lift . void . forkIO $ do let removedUsers = map lmId users \\ map lmId newUsers removedBots = map botMemId bots \\ map botMemId newBots - mapM_ (deleteBot (lUnqualified lcnv)) removedBots + mapM_ (deleteBot (tUnqualified lcnv)) removedBots for_ (nonEmpty removedUsers) $ \victims -> do -- FUTUREWORK: deal with remote members, too, see updateLocalConversation (Jira SQCORE-903) - Data.removeLocalMembersFromLocalConv (lUnqualified lcnv) victims + Data.removeLocalMembersFromLocalConv (tUnqualified lcnv) victims now <- liftIO getCurrentTime - let qvictims = QualifiedUserIdList . map (unTagged . qualifyAs lcnv) . toList $ victims - let e = Event MemberLeave (unTagged lcnv) qusr now (EdMembersLeave qvictims) + let qvictims = QualifiedUserIdList . map (qUntagged . qualifyAs lcnv) . toList $ victims + let e = Event MemberLeave (qUntagged lcnv) qusr now (EdMembersLeave qvictims) -- push event to all clients, including zconn -- since updateConversationAccess generates a second (member removal) event here traverse_ push1 $ @@ -323,7 +322,7 @@ updateLocalConversationReceiptMode :: Galley (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionReceiptModeUpdate update updateRemoteConversationReceiptMode :: @@ -352,11 +351,13 @@ updateConversationMessageTimer :: Public.ConversationMessageTimerUpdate -> Galley (UpdateResult Event) updateConversationMessageTimer usr zcon qcnv update = do - localDomain <- viewFederationDomain lusr <- qualifyLocal usr - if qDomain qcnv == localDomain - then updateLocalConversationMessageTimer lusr zcon (toLocal qcnv) update - else throwM federationNotImplemented + foldQualified + lusr + (updateLocalConversationMessageTimer lusr zcon) + (\_ _ -> throwM federationNotImplemented) + qcnv + update updateLocalConversationMessageTimer :: Local UserId -> @@ -366,7 +367,7 @@ updateLocalConversationMessageTimer :: Galley (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMessageTimerUpdate update -- | Update a local conversation, and notify all local and remote members. @@ -383,7 +384,7 @@ updateLocalConversation lcnv qusr con action = do getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) qusr - (lUnqualified lcnv) + (tUnqualified lcnv) -- perform checks lift $ ensureConversationActionAllowed action conv self @@ -561,7 +562,7 @@ joinConversation zusr zcon cnv access = do addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember lift $ notifyConversationMetadataUpdate - (unTagged lusr) + (qUntagged lusr) (Just zcon) lcnv (convTargets conv <> extraTargets) @@ -605,7 +606,7 @@ performAddMemberAction qusr conv invited role = do tms <- Data.teamMembersLimited tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers ensureAccessRole (Data.convAccessRole conv) userMembershipMap - tcv <- Data.teamConversation tid (lUnqualified lcnv) + tcv <- Data.teamConversation tid (tUnqualified lcnv) when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged ensureConnectedOrSameTeam qusr newUsers @@ -640,7 +641,7 @@ performAddMemberAction qusr conv invited role = do then do for_ convUsersLHStatus $ \(mem, status) -> when (consentGiven status == ConsentNotGiven) $ do - qvictim <- unTagged <$> qualifyLocal (lmId mem) + qvictim <- qUntagged <$> qualifyLocal (lmId mem) void . runMaybeT $ updateLocalConversation lcnv qvictim Nothing $ ConversationActionRemoveMember qvictim @@ -652,7 +653,7 @@ performAddMemberAction qusr conv invited role = do addMembersUnqualified :: UserId -> ConnId -> ConvId -> Public.Invite -> Galley (UpdateResult Event) addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do - qusers <- traverse (fmap unTagged . qualifyLocal) (toNonEmpty users) + qusers <- traverse (fmap qUntagged . qualifyLocal) (toNonEmpty users) addMembers zusr zcon cnv (Public.InviteQualified qusers role) addMembers :: UserId -> ConnId -> ConvId -> Public.InviteQualified -> Galley (UpdateResult Event) @@ -660,7 +661,7 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just zcon) $ + updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ ConversationActionAddMembers users role updateSelfMember :: UserId -> ConnId -> Qualified ConvId -> Public.MemberUpdate -> Galley () @@ -670,18 +671,18 @@ updateSelfMember zusr zcon qcnv update = do unless exists (throwErrorDescriptionType @ConvNotFound) Data.updateSelfMember lusr qcnv lusr update now <- liftIO getCurrentTime - let e = Event MemberStateUpdate qcnv (unTagged lusr) now (EdMemberUpdate (updateData lusr)) + let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) pushConversationEvent (Just zcon) e [zusr] [] where checkLocalMembership lcnv lusr = - isMember (lUnqualified lusr) - <$> Data.members (lUnqualified lcnv) + isMember (tUnqualified lusr) + <$> Data.members (tUnqualified lcnv) checkRemoteMembership rcnv lusr = isJust . Map.lookup rcnv - <$> Data.remoteConversationStatus (lUnqualified lusr) [rcnv] + <$> Data.remoteConversationStatus (tUnqualified lusr) [rcnv] updateData luid = MemberUpdateData - { misTarget = unTagged luid, + { misTarget = qUntagged luid, misOtrMutedStatus = mupOtrMuteStatus update, misOtrMutedRef = mupOtrMuteRef update, misOtrArchived = mupOtrArchive update, @@ -694,7 +695,7 @@ updateSelfMember zusr zcon qcnv update = do updateUnqualifiedSelfMember :: UserId -> ConnId -> ConvId -> Public.MemberUpdate -> Galley () updateUnqualifiedSelfMember zusr zcon cnv update = do lcnv <- qualifyLocal cnv - updateSelfMember zusr zcon (unTagged lcnv) update + updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: UserId -> @@ -707,7 +708,7 @@ updateOtherMemberUnqualified zusr zcon cnv victim update = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv lvictim <- qualifyLocal victim - updateOtherMemberLocalConv lcnv lusr zcon (unTagged lvictim) update + updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: UserId -> @@ -729,9 +730,9 @@ updateOtherMemberLocalConv :: Public.OtherMemberUpdate -> Galley () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - when (unTagged lusr == qvictim) $ + when (qUntagged lusr == qvictim) $ throwM invalidTargetUserOp - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMemberUpdate qvictim update updateOtherMemberRemoteConv :: @@ -747,7 +748,7 @@ removeMemberUnqualified :: UserId -> ConnId -> ConvId -> UserId -> Galley Remove removeMemberUnqualified zusr con cnv victim = do lcnv <- qualifyLocal cnv lvictim <- qualifyLocal victim - removeMemberQualified zusr con (unTagged lcnv) (unTagged lvictim) + removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: UserId -> @@ -765,8 +766,8 @@ removeMemberFromRemoteConv :: Maybe ConnId -> Qualified UserId -> Galley RemoveFromConversationResponse -removeMemberFromRemoteConv (unTagged -> qcnv) lusr _ victim - | unTagged lusr == victim = +removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim + | qUntagged lusr == victim = do let lc = FederatedGalley.LeaveConversationRequest (qUnqualified qcnv) (qUnqualified victim) let rpc = @@ -776,7 +777,7 @@ removeMemberFromRemoteConv (unTagged -> qcnv) lusr _ victim lc t <- liftIO getCurrentTime let successEvent = - Event MemberLeave qcnv (unTagged lusr) t $ + Event MemberLeave qcnv (qUntagged lusr) t $ EdMembersLeave (QualifiedUserIdList [victim]) mapRight (const successEvent) . FederatedGalley.leaveResponse <$> runFederated (qDomain qcnv) rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed @@ -788,7 +789,7 @@ performRemoveMemberAction :: performRemoveMemberAction conv victim = do loc <- qualifyLocal () guard $ isConvMember loc conv victim - let removeLocal u c = Data.removeLocalMembersFromLocalConv c (pure (lUnqualified u)) + let removeLocal u c = Data.removeLocalMembersFromLocalConv c (pure (tUnqualified u)) removeRemote u c = Data.removeRemoteMembersFromLocalConv c (pure u) lift $ foldQualified loc removeLocal removeRemote victim (Data.convId conv) @@ -803,7 +804,7 @@ removeMemberFromLocalConv lcnv lusr con victim = -- FUTUREWORK: actually return errors as part of the response instead of throwing fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT - . updateLocalConversation lcnv (unTagged lusr) con + . updateLocalConversation lcnv (qUntagged lusr) con . ConversationActionRemoveMember $ victim @@ -962,9 +963,12 @@ updateConversationName :: Galley (Maybe Public.Event) updateConversationName zusr zcon qcnv convRename = do lusr <- qualifyLocal zusr - if qDomain qcnv == lDomain lusr - then updateLocalConversationName lusr zcon (toLocal qcnv) convRename - else throwM federationNotImplemented + foldQualified + lusr + (updateLocalConversationName lusr zcon) + (\_ _ -> throwM federationNotImplemented) + qcnv + convRename updateUnqualifiedConversationName :: UserId -> @@ -984,10 +988,10 @@ updateLocalConversationName :: Public.ConversationRename -> Galley (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do - alive <- Data.isConvAlive (lUnqualified lcnv) + alive <- Data.isConvAlive (tUnqualified lcnv) if alive then updateLiveLocalConversationName lusr zcon lcnv convRename - else Nothing <$ Data.deleteConversation (lUnqualified lcnv) + else Nothing <$ Data.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: Local UserId -> @@ -997,7 +1001,7 @@ updateLiveLocalConversationName :: Galley (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionRename rename notifyConversationMetadataUpdate :: @@ -1007,14 +1011,14 @@ notifyConversationMetadataUpdate :: NotificationTargets -> ConversationAction -> Galley Event -notifyConversationMetadataUpdate quid con (Tagged qcnv) targets action = do +notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do localDomain <- viewFederationDomain now <- liftIO getCurrentTime let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = partitionRemote (toList (ntRemotes targets)) - void . pooledForConcurrentlyN 8 rusersByDomain $ \(domain, uids) -> do + let rusersByDomain = indexRemote (toList (ntRemotes targets)) + void . pooledForConcurrentlyN 8 rusersByDomain $ \(qUntagged -> Qualified uids domain) -> do let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action rpc = FederatedGalley.onConversationUpdated @@ -1073,7 +1077,7 @@ addBot zusr zcon b = do (bots, users) <- regularConvChecks lusr c t <- liftIO getCurrentTime Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient) - (e, bm) <- Data.addBotMember (unTagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t + (e, bm) <- Data.addBotMember (qUntagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e) @@ -1087,7 +1091,7 @@ addBot zusr zcon b = do ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) - ensureMemberLimit (toList $ Data.convLocalMembers c) [unTagged botId] + ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] return (bots, users) teamConvChecks cid tid = do tcv <- Data.teamConversation tid cid diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index bd21ee4f92..045588dc95 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -36,7 +36,6 @@ import qualified Data.Map as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set -import Data.Tagged import qualified Data.Text.Lazy as LT import Data.Time import Galley.API.Error @@ -255,7 +254,7 @@ acceptOne2One usr conv conn = do throwM badConvState now <- liftIO getCurrentTime mm <- Data.addMember lcid lusr - let e = memberJoinEvent lusr (unTagged lcid) now mm [] + let e = memberJoinEvent lusr (qUntagged lcid) now mm [] conv' <- if isJust (find ((usr /=) . lmId) mems) then promote else pure conv let mems' = mems <> toList mm for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> @@ -281,11 +280,11 @@ memberJoinEvent :: [RemoteMember] -> Event memberJoinEvent lorig qconv t lmems rmems = - Event MemberJoin qconv (unTagged lorig) t $ + Event MemberJoin qconv (qUntagged lorig) t $ EdMembersJoin (SimpleMembers (map localToSimple lmems <> map remoteToSimple rmems)) where - localToSimple u = SimpleMember (unTagged (qualifyAs lorig (lmId u))) (lmConvRoleName u) - remoteToSimple u = SimpleMember (unTagged (rmId u)) (rmConvRoleName u) + localToSimple u = SimpleMember (qUntagged (qualifyAs lorig (lmId u))) (lmConvRoleName u) + remoteToSimple u = SimpleMember (qUntagged (rmId u)) (rmConvRoleName u) isBot :: LocalMember -> Bool isBot = isJust . lmService @@ -309,7 +308,7 @@ instance IsConvMemberId UserId LocalMember where getConvMember _ conv u = find ((u ==) . lmId) (Data.convLocalMembers conv) instance IsConvMemberId (Local UserId) LocalMember where - getConvMember loc conv = getConvMember loc conv . lUnqualified + getConvMember loc conv = getConvMember loc conv . tUnqualified instance IsConvMemberId (Remote UserId) RemoteMember where getConvMember _ conv u = find ((u ==) . rmId) (Data.convRemoteMembers conv) @@ -327,11 +326,11 @@ class IsConvMember mem where instance IsConvMember LocalMember where convMemberRole = lmConvRoleName - convMemberId loc mem = unTagged (qualifyAs loc (lmId mem)) + convMemberId loc mem = qUntagged (qualifyAs loc (lmId mem)) instance IsConvMember RemoteMember where convMemberRole = rmConvRoleName - convMemberId _ = unTagged . rmId + convMemberId _ = qUntagged . rmId instance IsConvMember (Either LocalMember RemoteMember) where convMemberRole = either convMemberRole convMemberRole @@ -370,7 +369,7 @@ instance Monoid NotificationTargets where instance IsNotificationTarget (Local UserId) where ntAdd _ luid nt = - nt {ntLocals = Set.insert (lUnqualified luid) (ntLocals nt)} + nt {ntLocals = Set.insert (tUnqualified luid) (ntLocals nt)} instance IsNotificationTarget (Remote UserId) where ntAdd _ ruid nt = nt {ntRemotes = Set.insert ruid (ntRemotes nt)} @@ -447,24 +446,8 @@ ensureOtherMember :: Galley (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ - (Left <$> find ((== quid) . (`Qualified` lDomain loc) . lmId) (Data.convLocalMembers conv)) - <|> (Right <$> find ((== quid) . unTagged . rmId) (Data.convRemoteMembers conv)) - --- | Note that we use 2 nearly identical functions but slightly different --- semantics; when using `getSelfMemberQualified`, if that user is _not_ part of --- the conversation, we don't want to disclose that such a conversation with --- that id exists. -getSelfMemberQualified :: - (Foldable t, Monad m) => - Domain -> - Qualified UserId -> - t LocalMember -> - t RemoteMember -> - ExceptT ConvNotFound m (Either LocalMember RemoteMember) -getSelfMemberQualified localDomain qusr@(Qualified usr userDomain) lmems rmems = do - if localDomain == userDomain - then Left <$> getSelfMemberFromLocals usr lmems - else Right <$> getSelfMemberFromRemotes (toRemote qusr) rmems + (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) + <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) getSelfMemberFromRemotes :: (Foldable t, Monad m) => @@ -506,7 +489,7 @@ getQualifiedMember :: getQualifiedMember loc e qusr conv = foldQualified loc - (\lusr -> Left <$> getLocalMember e (lUnqualified lusr) (Data.convLocalMembers conv)) + (\lusr -> Left <$> getLocalMember e (tUnqualified lusr) (Data.convLocalMembers conv)) (\rusr -> Right <$> getRemoteMember e rusr (Data.convRemoteMembers conv)) qusr @@ -603,16 +586,15 @@ viewFederationDomain :: MonadReader Env m => m Domain viewFederationDomain = view (options . optSettings . setFederationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) -qualifyLocal a = fmap (toLocal . Qualified a) viewFederationDomain +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a checkRemoteUsersExist :: (Functor f, Foldable f) => f (Remote UserId) -> Galley () checkRemoteUsersExist = -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain - traverse_ (uncurry checkRemotesFor) - . partitionRemote + traverse_ checkRemotesFor . indexRemote -checkRemotesFor :: Domain -> [UserId] -> Galley () -checkRemotesFor domain uids = do +checkRemotesFor :: Remote [UserId] -> Galley () +checkRemotesFor (qUntagged -> Qualified uids domain) = do let rpc = FederatedBrig.getUsersByIds FederatedBrig.clientRoutes uids users <- runFederatedBrig domain rpc let uids' = @@ -713,9 +695,9 @@ fromNewRemoteConversation d NewRemoteConversation {..} = conv :: Public.Member -> [OtherMember] -> Public.Conversation conv this others = Public.Conversation + rcCnvId ConversationMetadata - { cnvmQualifiedId = rcCnvId, - cnvmType = rcCnvType, + { cnvmType = rcCnvType, -- FUTUREWORK: Document this is the same domain as the conversation -- domain cnvmCreator = qUnqualified rcOrigUserId, @@ -743,9 +725,9 @@ registerRemoteConversationMemberships now localDomain c = do -- FUTUREWORK: parallelise federated requests traverse_ (registerRemoteConversations rc) . Map.keys - . partitionQualified + . indexQualified . nubOrd - . map (unTagged . rmId) + . map (qUntagged . rmId) . Data.convRemoteMembers $ c where diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index afb7d87713..55be7a1381 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -122,7 +122,7 @@ module Galley.Data where import Brig.Types.Code -import Cassandra hiding (Tagged) +import Cassandra import Cassandra.Util import Control.Arrow (second) import Control.Exception (ErrorCall (ErrorCall)) @@ -143,7 +143,6 @@ import qualified Data.Monoid import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import qualified Data.UUID.Tagged as U import Data.UUID.V4 (nextRandom) import Galley.App @@ -544,13 +543,12 @@ toConv cid mms remoteMems conv = f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm conversationMeta :: MonadClient m => Domain -> ConvId -> m (Maybe ConversationMetadata) -conversationMeta localDomain conv = +conversationMeta _localDomain conv = fmap toConvMeta <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) where toConvMeta (t, c, a, r, n, i, _, mt, rm) = ConversationMetadata - (Qualified conv localDomain) t c (defAccess t a) @@ -609,22 +607,22 @@ remoteConversationStatus :: m (Map (Remote ConvId) MemberStatus) remoteConversationStatus uid = fmap mconcat - . pooledMapConcurrentlyN 8 (uncurry (remoteConversationStatusOnDomain uid)) - . partitionRemote + . pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) + . indexRemote -remoteConversationStatusOnDomain :: MonadClient m => UserId -> Domain -> [ConvId] -> m (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomain uid domain convs = +remoteConversationStatusOnDomain :: MonadClient m => UserId -> Remote [ConvId] -> m (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomain uid rconvs = Map.fromList . map toPair - <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, domain, convs)) + <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) where toPair (conv, omus, omur, oar, oarr, hid, hidr) = - ( toRemote (Qualified conv domain), + ( qualifyAs rconvs conv, toMemberStatus (omus, omur, oar, oarr, hid, hidr) ) conversationsRemote :: (MonadClient m) => UserId -> m [Remote ConvId] conversationsRemote usr = do - (\(d, c) -> toRemote $ Qualified c d) <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) + uncurry toRemoteUnsafe <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) createConversation :: MonadClient m => @@ -642,7 +640,7 @@ createConversation :: createConversation lusr name acc role others tinfo mtimer recpt othersConversationRole = do conv <- Id <$> liftIO nextRandom let lconv = qualifyAs lusr conv - usr = lUnqualified lusr + usr = tUnqualified lusr retry x5 $ case tinfo of Nothing -> write Cql.insertConv (params Quorum (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Nothing, mtimer, recpt)) @@ -652,17 +650,17 @@ createConversation lusr name acc role others tinfo mtimer recpt othersConversati addPrepQuery Cql.insertConv (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Just (cnvTeamId ti), mtimer, recpt) addPrepQuery Cql.insertTeamConv (cnvTeamId ti, conv, cnvManaged ti) let newUsers = fmap (,othersConversationRole) (fromConvSize others) - (lmems, rmems) <- addMembers lconv (ulAddLocal (lUnqualified lusr, roleNameWireAdmin) newUsers) + (lmems, rmems) <- addMembers lconv (ulAddLocal (tUnqualified lusr, roleNameWireAdmin) newUsers) pure $ newConv conv RegularConv usr lmems rmems acc role name (cnvTeamId <$> tinfo) mtimer recpt createSelfConversation :: MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> m Conversation createSelfConversation lusr name = do - let usr = lUnqualified lusr + let usr = tUnqualified lusr conv = selfConv usr lconv = qualifyAs lusr conv retry x5 $ write Cql.insertConv (params Quorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - (lmems, rmems) <- addMembers lconv (UserList [lUnqualified lusr] []) + (lmems, rmems) <- addMembers lconv (UserList [tUnqualified lusr] []) pure $ newConv conv SelfConv usr lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing createConnectConversation :: @@ -770,10 +768,9 @@ newConv cid ct usr mems rMems acc role name tid mtimer rMode = convReceiptMode = rMode } -convMetadata :: Domain -> Conversation -> ConversationMetadata -convMetadata localDomain c = +convMetadata :: Conversation -> ConversationMetadata +convMetadata c = ConversationMetadata - (Qualified (convId c) localDomain) (convType c) (convCreator c) (convAccess c) @@ -845,7 +842,7 @@ remoteMemberLists convs = do mkMem (cnv, domain, usr, role) = (cnv, toRemoteMember usr domain role) toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember -toRemoteMember u d = RemoteMember (toRemote (Qualified u d)) +toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) memberLists :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => @@ -871,7 +868,7 @@ lookupRemoteMembers conv = join <$> remoteMemberLists [conv] -- | Add a member to a local conversation, as an admin. addMember :: MonadClient m => Local ConvId -> Local UserId -> m [LocalMember] -addMember c u = fst <$> addMembers c (UserList [lUnqualified u] []) +addMember c u = fst <$> addMembers c (UserList [tUnqualified u] []) class ToUserRole a where toUserRole :: a -> (UserId, RoleName) @@ -897,7 +894,7 @@ addMembers :: Local ConvId -> UserList a -> m ([LocalMember], [RemoteMember]) -addMembers (lUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do +addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do -- batch statement with 500 users are known to be above the batch size limit -- and throw "Batch too large" errors. Therefor we chunk requests and insert -- sequentially. (parallelizing would not aid performance as the partition @@ -920,7 +917,7 @@ addMembers (lUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = retry x5 . batch $ do setType BatchLogged setConsistency Quorum - for_ chunk $ \(unTagged -> Qualified (uid, role) domain) -> do + for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do -- User is remote, so we only add it to the member_remote_user -- table, but the reverse mapping has to be done on the remote -- backend; so we assume an additional call to their backend has @@ -967,15 +964,15 @@ updateSelfMemberLocalConv lcid luid mup = do for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, lUnqualified lcid, lUnqualified luid) + (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery Cql.updateOtrMemberArchived - (a, mupOtrArchiveRef mup, lUnqualified lcid, lUnqualified luid) + (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery Cql.updateMemberHidden - (h, mupHiddenRef mup, lUnqualified lcid, lUnqualified luid) + (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) updateSelfMemberRemoteConv :: MonadClient m => @@ -983,22 +980,22 @@ updateSelfMemberRemoteConv :: Local UserId -> MemberUpdate -> m () -updateSelfMemberRemoteConv (Tagged (Qualified cid domain)) luid mup = do +updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateRemoteOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, domain, cid, lUnqualified luid) + (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery Cql.updateRemoteOtrMemberArchived - (a, mupOtrArchiveRef mup, domain, cid, lUnqualified luid) + (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery Cql.updateRemoteMemberHidden - (h, mupHiddenRef mup, domain, cid, lUnqualified luid) + (h, mupHiddenRef mup, domain, cid, tUnqualified luid) updateOtherMember :: MonadClient m => @@ -1018,14 +1015,14 @@ updateOtherMemberLocalConv :: updateOtherMemberLocalConv lcid quid omu = do let addQuery r - | lDomain lcid == qDomain quid = + | tDomain lcid == qDomain quid = addPrepQuery Cql.updateMemberConvRoleName - (r, lUnqualified lcid, qUnqualified quid) + (r, tUnqualified lcid, qUnqualified quid) | otherwise = addPrepQuery Cql.updateRemoteMemberConvRoleName - (r, lUnqualified lcid, qDomain quid, qUnqualified quid) + (r, tUnqualified lcid, qDomain quid, qUnqualified quid) retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum @@ -1077,7 +1074,7 @@ removeRemoteMembersFromLocalConv cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum - for_ victims $ \(unTagged -> Qualified uid domain) -> + for_ victims $ \(qUntagged -> Qualified uid domain) -> addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) removeLocalMembersFromRemoteConv :: @@ -1114,7 +1111,7 @@ newMemberWithRole (u, r) = } newRemoteMemberWithRole :: Remote (UserId, RoleName) -> RemoteMember -newRemoteMemberWithRole ur@(unTagged -> (Qualified (u, r) _)) = +newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = RemoteMember { rmId = qualifyAs ur u, rmConvRoleName = r diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index 59d31de155..ffcabd6984 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -24,7 +24,6 @@ module Galley.Types.UserList where import Data.Qualified -import Data.Tagged import Imports -- | A list of users, partitioned into locals and remotes @@ -35,10 +34,10 @@ data UserList a = UserList deriving (Functor, Foldable, Traversable) toUserList :: Foldable f => Local x -> f (Qualified a) -> UserList a -toUserList loc = uncurry (flip UserList) . partitionRemoteOrLocalIds' (lDomain loc) +toUserList loc = uncurry UserList . partitionQualified loc ulAddLocal :: a -> UserList a -> UserList a ulAddLocal x ul = ul {ulLocals = x : ulLocals ul} ulAll :: Local x -> UserList a -> [Qualified a] -ulAll loc ul = map (unTagged . qualifyAs loc) (ulLocals ul) <> map unTagged (ulRemotes ul) +ulAll loc ul = map (qUntagged . qualifyAs loc) (ulLocals ul) <> map qUntagged (ulRemotes ul) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 065f4f9768..7d0b95730b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1727,7 +1727,6 @@ getConvQualifiedOk = do accessConvMeta :: TestM () accessConvMeta = do - localDomain <- viewFederationDomain g <- view tsGalley alice <- randomUser bob <- randomUser @@ -1736,7 +1735,6 @@ accessConvMeta = do conv <- decodeConvId <$> postConv alice [bob, chuck] (Just "gossip") [] Nothing Nothing let meta = ConversationMetadata - (Qualified conv localDomain) RegularConv alice [InviteAccess] @@ -1846,10 +1844,11 @@ testGetQualifiedRemoteConv = do registerRemoteConv remoteConvId bobQ Nothing (Set.fromList [aliceAsOtherMember]) - let mockConversation = mkConv remoteConvId bobId roleNameWireAdmin [bobAsOtherMember] + let mockConversation = mkConv convId bobId roleNameWireAdmin [bobAsOtherMember] remoteConversationResponse = GetConversationsResponse [mockConversation] expected = Conversation + remoteConvId (rcnvMetadata mockConversation) (ConvMembers aliceAsSelfMember (rcmOthers (rcnvMembers mockConversation))) @@ -1893,7 +1892,7 @@ testGetQualifiedRemoteConvNotFoundOnRemote = do const 404 === statusCode const (Just "no-conversation") === view (at "label") . responseJsonUnsafe @Object --- | Tests getting many conversations given their ids. +-- | Tests getting many converations given their ids. -- -- In this test, Alice is a local user, who will be asking for metadata of these -- conversations: @@ -1948,8 +1947,8 @@ testBulkGetQualifiedConvs = do let bobAsOtherMember = OtherMember bobQ Nothing roleNameWireAdmin carlAsOtherMember = OtherMember carlQ Nothing roleNameWireAdmin - mockConversationA = mkConv remoteConvIdA bobId roleNameWireAdmin [bobAsOtherMember] - mockConversationB = mkConv remoteConvIdB carlId roleNameWireAdmin [carlAsOtherMember] + mockConversationA = mkConv (qUnqualified remoteConvIdA) bobId roleNameWireAdmin [bobAsOtherMember] + mockConversationB = mkConv (qUnqualified remoteConvIdB) carlId roleNameWireAdmin [carlAsOtherMember] req = ListConversations . unsafeRange $ [ localConvId, @@ -1981,8 +1980,8 @@ testBulkGetQualifiedConvs = do let expectedFound = sortOn cnvQualifiedId - $ maybeToList (remoteConversationView alice defMemberStatus mockConversationA) - <> maybeToList (remoteConversationView alice defMemberStatus mockConversationB) + $ maybeToList (remoteConversationView alice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) + <> maybeToList (remoteConversationView alice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) <> [localConv] actualFound = sortOn cnvQualifiedId $ crFound convs assertEqual "found conversations" expectedFound actualFound @@ -2734,7 +2733,7 @@ putRemoteConvMemberOk update = do let bobAsLocal = LocalMember (qUnqualified qbob) defMemberStatus Nothing roleNameWireAdmin let mockConversation = mkConv - qconv + (qUnqualified qconv) (qUnqualified qbob) roleNameWireMember [localMemberToOther remoteDomain bobAsLocal] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 9e5895ab1a..eace125c2a 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -110,7 +110,7 @@ getConversationsAllFound = do (map (qUnqualified . cnvQualifiedId) [cnv2]) ) - let c2 = find ((== cnvQualifiedId cnv2) . cnvmQualifiedId . rcnvMetadata) cs + let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) cs liftIO $ do assertEqual diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 452ec2c7f4..ec3bbcc83f 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1492,7 +1492,7 @@ connectUsers u us = void $ connectUsersWith expect2xx u us connectLocalQualifiedUsers :: UserId -> List1 (Qualified UserId) -> TestM () connectLocalQualifiedUsers u us = do localDomain <- viewFederationDomain - let partitionMap = partitionQualified . toList . toNonEmpty $ us + let partitionMap = indexQualified . toList . toNonEmpty $ us -- FUTUREWORK: connect all users, not just those on the same domain as 'u' case LMap.lookup localDomain partitionMap of Nothing -> err @@ -1848,7 +1848,7 @@ randomEmail = do uid <- liftIO nextRandom return $ Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" -selfConv :: UserId -> Id C +selfConv :: UserId -> ConvId selfConv u = Id (toUUID u) -- TODO: Refactor, as used also in other services @@ -1913,15 +1913,15 @@ someLastPrekeys = ] mkConv :: - Qualified ConvId -> + ConvId -> UserId -> RoleName -> [OtherMember] -> FederatedGalley.RemoteConversation mkConv cnvId creator selfRole otherMembers = FederatedGalley.RemoteConversation + cnvId ( ConversationMetadata - cnvId RegularConv creator [] diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index f1c8b23780..940178095f 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -24,7 +24,6 @@ import Data.Containers.ListUtils (nubOrdOn) import Data.Domain import Data.Id import Data.Qualified -import Data.Tagged import Galley.API.Mapping import qualified Galley.Data as Data import Galley.Types.Conversations.Members @@ -51,7 +50,7 @@ tests = testProperty "conversation view metadata is correct" $ \(ConvWithLocalUser c uid) dom -> fmap cnvMetadata (conversationViewMaybe dom uid c) - == Just (Data.convMetadata dom c), + == Just (Data.convMetadata c), testProperty "other members in conversation view do not contain self" $ \(ConvWithLocalUser c uid) dom -> case conversationViewMaybe dom uid c of Nothing -> False @@ -70,24 +69,24 @@ tests = ==> isNothing (conversationViewMaybe dom uid c), testProperty "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> isJust (conversationToRemote dom ruid c), testProperty "self user role in remote conversation view is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> fmap (rcmSelfRole . rcnvMembers) (conversationToRemote dom ruid c) == Just roleNameWireMember, testProperty "remote conversation view metadata is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> fmap (rcnvMetadata) (conversationToRemote dom ruid c) - == Just (Data.convMetadata dom c), + == Just (Data.convMetadata c), testProperty "remote conversation view does not contain self" $ \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of Nothing -> False Just rcnv -> not - ( unTagged ruid + ( qUntagged ruid `elem` (map omQualifiedId (rcmOthers (rcnvMembers rcnv))) ) ] @@ -101,7 +100,7 @@ cnvUids dom c = convUids :: Domain -> Data.Conversation -> [Qualified UserId] convUids dom c = map ((`Qualified` dom) . lmId) (Data.convLocalMembers c) - <> map (unTagged . rmId) (Data.convRemoteMembers c) + <> map (qUntagged . rmId) (Data.convRemoteMembers c) genLocalMember :: Gen LocalMember genLocalMember =