From 3d5684023c54fe580ab27c11d7dae8f19a29ddbc Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 10 Jun 2020 10:08:00 +0200 Subject: [PATCH 1/7] Add team level flag for digital signtaures (#1132) --- libs/galley-types/src/Galley/Types/Teams.hs | 1 + libs/wire-api/src/Wire/API/Team/Feature.hs | 3 + services/galley/galley.cabal | 3 +- services/galley/schema/src/Main.hs | 4 +- .../src/V43_TeamFeatureDigitalSignatures.hs | 29 ++++ services/galley/src/Galley/API/Teams.hs | 12 ++ services/galley/src/Galley/Data.hs | 2 +- .../galley/src/Galley/Data/TeamFeatures.hs | 1 + services/galley/test/integration/API/Teams.hs | 150 ++++++++++-------- 9 files changed, 135 insertions(+), 70 deletions(-) create mode 100644 services/galley/schema/src/V43_TeamFeatureDigitalSignatures.hs diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index cbd0a603b33..bfcf6c6aa05 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -336,6 +336,7 @@ roleHiddenPermissions role = HiddenPermissions p p ViewTeamFeature TeamFeatureSSO, ViewTeamFeature TeamFeatureSearchVisibility, ViewTeamFeature TeamFeatureValidateSAMLEmails, + ViewTeamFeature TeamFeatureDigitalSignatures, ViewLegalHoldUserSettings, ViewTeamSearchVisibility ] diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 1f5296df863..8f8653f246f 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -44,6 +44,7 @@ data TeamFeatureName | TeamFeatureSSO | TeamFeatureSearchVisibility | TeamFeatureValidateSAMLEmails + | TeamFeatureDigitalSignatures deriving stock (Eq, Show, Ord, Generic, Enum, Bounded) deriving (Arbitrary) via (GenericUniform TeamFeatureName) @@ -55,6 +56,7 @@ instance FromByteString TeamFeatureName where Right "sso" -> pure TeamFeatureSSO Right "search-visibility" -> pure TeamFeatureSearchVisibility Right "validate-saml-emails" -> pure TeamFeatureValidateSAMLEmails + Right "digital-signatures" -> pure TeamFeatureDigitalSignatures Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t instance ToByteString TeamFeatureName where @@ -62,6 +64,7 @@ instance ToByteString TeamFeatureName where builder TeamFeatureSSO = "sso" builder TeamFeatureSearchVisibility = "search-visibility" builder TeamFeatureValidateSAMLEmails = "validate-saml-emails" + builder TeamFeatureDigitalSignatures = "digital-signatures" typeTeamFeatureName :: Doc.DataType typeTeamFeatureName = Doc.string . Doc.enum $ cs . toByteString' <$> [(minBound :: TeamFeatureName) ..] diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 68621a09ea1..1a0c55e5ce4 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 79de6e0df943f81b06a385534f150c05146658d23c9b577b6e67d66cb9c67625 +-- hash: 68e5113c1088325ae314f68dcfe34cc49353b1500f48dff408c8a045cf8d94c6 name: galley version: 0.83.0 @@ -336,6 +336,7 @@ executable galley-schema V40_CreateTableDataMigration V41_TeamNotificationQueue V42_TeamFeatureValidateSamlEmails + V43_TeamFeatureDigitalSignatures Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index a1c5e669b10..df169403b7d 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -45,6 +45,7 @@ import qualified V39 import qualified V40_CreateTableDataMigration import qualified V41_TeamNotificationQueue import qualified V42_TeamFeatureValidateSamlEmails +import qualified V43_TeamFeatureDigitalSignatures main :: IO () main = do @@ -75,7 +76,8 @@ main = do V39.migration, V40_CreateTableDataMigration.migration, V41_TeamNotificationQueue.migration, - V42_TeamFeatureValidateSamlEmails.migration + V42_TeamFeatureValidateSamlEmails.migration, + V43_TeamFeatureDigitalSignatures.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Data ] diff --git a/services/galley/schema/src/V43_TeamFeatureDigitalSignatures.hs b/services/galley/schema/src/V43_TeamFeatureDigitalSignatures.hs new file mode 100644 index 00000000000..fb31e6efd0e --- /dev/null +++ b/services/galley/schema/src/V43_TeamFeatureDigitalSignatures.hs @@ -0,0 +1,29 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V43_TeamFeatureDigitalSignatures + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 43 "Add feature flag for digital signatures" $ do + schema' [r| ALTER TABLE team_features ADD digital_signatures int; |] diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index c8ba67affa8..b883a53436e 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -872,6 +872,7 @@ getFeatureStatusInternal tid featureName = do Public.TeamFeatureSSO -> getSSOStatusInternal tid Public.TeamFeatureSearchVisibility -> getTeamSearchVisibilityAvailableInternal tid Public.TeamFeatureValidateSAMLEmails -> getValidateSAMLEmailsInternal tid + Public.TeamFeatureDigitalSignatures -> getDigitalSignaturesInternal tid -- | Enable or disable feature flag for a team. To be called only from authorized personnel -- (e.g., from a backoffice tool) @@ -886,6 +887,7 @@ setFeatureStatusInternal tid featureName status = do Public.TeamFeatureSSO -> setSSOStatusInternal tid status Public.TeamFeatureSearchVisibility -> setTeamSearchVisibilityAvailableInternal tid status Public.TeamFeatureValidateSAMLEmails -> setValidateSAMLEmailsInternal tid status + Public.TeamFeatureDigitalSignatures -> setDigitalSignaturesInternal tid status getSSOStatusInternal :: TeamId -> Galley Public.TeamFeatureStatus getSSOStatusInternal tid = do @@ -962,6 +964,16 @@ getValidateSAMLEmailsInternal tid = setValidateSAMLEmailsInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () setValidateSAMLEmailsInternal tid = TeamFeatures.setFlag tid Public.TeamFeatureValidateSAMLEmails +getDigitalSignaturesInternal :: TeamId -> Galley Public.TeamFeatureStatus +getDigitalSignaturesInternal tid = + -- FUTUREWORK: we may also want to get a default from the server config file here, like for + -- sso, and team search visibility. + fromMaybe Public.TeamFeatureDisabled + <$> TeamFeatures.getFlag tid Public.TeamFeatureDigitalSignatures + +setDigitalSignaturesInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () +setDigitalSignaturesInternal tid = TeamFeatures.setFlag tid Public.TeamFeatureDigitalSignatures + -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley Response getSearchVisibilityInternalH (tid ::: _) = diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 6c32b6caa0c..05417141416 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -172,7 +172,7 @@ resultSetResult :: ResultSet a -> [a] resultSetResult = result . page schemaVersion :: Int32 -schemaVersion = 42 +schemaVersion = 43 -- | Insert a conversation code insertCode :: MonadClient m => Code -> m () diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 49072334ee8..8b6e12d1ffa 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -49,3 +49,4 @@ toCol TeamFeatureLegalHold = "legalhold_status" toCol TeamFeatureSSO = "sso_status" toCol TeamFeatureSearchVisibility = "search_visibility_status" toCol TeamFeatureValidateSAMLEmails = "validate_saml_emails" +toCol TeamFeatureDigitalSignatures = "digital_signatures" diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 97ceec2b938..6da1d9c7d37 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1885,29 +1885,11 @@ newTeamMember' perms uid = newTeamMember uid perms Nothing -- 'putTeamFeatureFlagInternal'. Since these functions all work in slightly different monads -- and with different kinds of internal checks, it's quite tedious to do so. -getSSOEnabled :: HasCallStack => UserId -> TeamId -> TestM ResponseLBS -getSSOEnabled uid tid = do - g <- view tsGalley - get $ - g - . paths ["teams", toByteString' tid, "features", "sso"] - . zUser uid - getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS -getSSOEnabledInternal tid = do - g <- view tsGalley - get $ - g - . paths ["i", "teams", toByteString' tid, "features", "sso"] +getSSOEnabledInternal = getTeamFeatureFlagInternal Public.TeamFeatureSSO putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatus -> TestM () -putSSOEnabledInternal tid enabled = do - g <- view tsGalley - void . put $ - g - . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json enabled - . expect2xx +putSSOEnabledInternal = putTeamFeatureFlagInternal' Public.TeamFeatureSSO expect2xx getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS getSearchVisibility g uid tid = do @@ -1925,75 +1907,98 @@ putSearchVisibility g uid tid vis = do . json (TeamSearchVisibilityView vis) getTeamSearchVisibilityAvailable :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS -getTeamSearchVisibilityAvailable g uid tid = do - get $ - g - . paths ["teams", toByteString' tid, "features", "search-visibility"] - . zUser uid +getTeamSearchVisibilityAvailable = getTeamFeatureFlagWithGalley Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS -getTeamSearchVisibilityAvailableInternal g tid = do - get $ - g - . paths ["i", "teams", toByteString' tid, "features", "search-visibility"] +getTeamSearchVisibilityAvailableInternal = + getTeamFeatureFlagInternalWithGalley Public.TeamFeatureSearchVisibility putTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> (MonadIO m, MonadHttp m) => m () -putTeamSearchVisibilityAvailableInternal g tid status = do +putTeamSearchVisibilityAvailableInternal g = + putTeamFeatureFlagInternalWithGalleyAndMod Public.TeamFeatureSearchVisibility g expect2xx + +putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () +putLegalHoldEnabledInternal' = putTeamFeatureFlagInternal' Public.TeamFeatureLegalHold + +putTeamFeatureFlagInternal' :: HasCallStack => Public.TeamFeatureName -> (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () +putTeamFeatureFlagInternal' feature reqmod tid status = do + g <- view tsGalley + putTeamFeatureFlagInternalWithGalleyAndMod feature g reqmod tid status + +putTeamFeatureFlagInternalWithGalleyAndMod :: + (MonadIO m, MonadHttp m, HasCallStack) => + Public.TeamFeatureName -> + (Request -> Request) -> + (Request -> Request) -> + TeamId -> + Public.TeamFeatureStatus -> + m () +putTeamFeatureFlagInternalWithGalleyAndMod feature galley reqmod tid status = void . put $ - g - . paths ["i", "teams", toByteString' tid, "features", "search-visibility"] + galley + . paths ["i", "teams", toByteString' tid, "features", toByteString' feature] . json status - . expect2xx + . reqmod -getLegalHoldEnabled :: HasCallStack => UserId -> TeamId -> TestM ResponseLBS -getLegalHoldEnabled uid tid = do +getTeamFeatureFlagInternal :: HasCallStack => Public.TeamFeatureName -> TeamId -> TestM ResponseLBS +getTeamFeatureFlagInternal feature tid = do g <- view tsGalley - get $ - g - . paths ["teams", toByteString' tid, "features", "legalhold"] - . zUser uid + getTeamFeatureFlagInternalWithGalley feature g tid -getLegalHoldEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS -getLegalHoldEnabledInternal tid = do - g <- view tsGalley +getTeamFeatureFlagInternalWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => Public.TeamFeatureName -> (Request -> Request) -> HasCallStack => TeamId -> m ResponseLBS +getTeamFeatureFlagInternalWithGalley feature g tid = do get $ g - . paths ["i", "teams", toByteString' tid, "features", "legalhold"] - -putLegalHoldEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatus -> TestM () -putLegalHoldEnabledInternal = putLegalHoldEnabledInternal' expect2xx + . paths ["i", "teams", toByteString' tid, "features", toByteString' feature] -putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () -putLegalHoldEnabledInternal' reqmod tid enabled = do +getTeamFeatureFlag :: HasCallStack => Public.TeamFeatureName -> UserId -> TeamId -> TestM ResponseLBS +getTeamFeatureFlag feature uid tid = do g <- view tsGalley - void . put $ - g - . paths ["i", "teams", toByteString' tid, "features", "legalhold"] - . json enabled - . reqmod + getTeamFeatureFlagWithGalley feature g uid tid + +getTeamFeatureFlagWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => Public.TeamFeatureName -> (Request -> Request) -> UserId -> TeamId -> m ResponseLBS +getTeamFeatureFlagWithGalley feature galley uid tid = do + get $ + galley + . paths ["teams", toByteString' tid, "features", toByteString' feature] + . zUser uid testFeatureFlags :: TestM () testFeatureFlags = do owner <- Util.randomUser + member <- Util.randomUser tid <- Util.createNonBindingTeam "foo" owner [] + Util.connectUsers owner (list1 member []) + Util.addTeamMember owner tid (newTeamMember member (rolePermissions RoleMember) Nothing) - -- sso - - let getSSO :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getSSO expected = getSSOEnabled owner tid !!! do + -- Get/Set flag while expecting 200 + let getFlag :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + getFlag feature expected = getTeamFeatureFlag feature member tid !!! do statusCode === const 200 responseJsonEither === const (Right expected) - getSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getSSOInternal expected = getSSOEnabledInternal tid !!! do + getFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + getFlagInternal feature expected = getTeamFeatureFlagInternal feature tid !!! do statusCode === const 200 responseJsonEither === const (Right expected) + setFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + setFlagInternal feature = putTeamFeatureFlagInternal' feature expect2xx tid + + -- sso + + let getSSO :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getSSO = getFlag Public.TeamFeatureSSO + getSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getSSOInternal = getFlagInternal Public.TeamFeatureSSO setSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - setSSOInternal = putSSOEnabledInternal tid + setSSOInternal = setFlagInternal Public.TeamFeatureSSO featureSSO <- view (tsGConf . optSettings . setFeatureFlags . flagSSO) case featureSSO of FeatureSSODisabledByDefault -> do + -- Test default getSSO Public.TeamFeatureDisabled getSSOInternal Public.TeamFeatureDisabled + + -- Test override setSSOInternal Public.TeamFeatureEnabled getSSO Public.TeamFeatureEnabled getSSOInternal Public.TeamFeatureEnabled @@ -2006,15 +2011,11 @@ testFeatureFlags = do -- legalhold let getLegalHold :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getLegalHold expected = getLegalHoldEnabled owner tid !!! do - statusCode === const 200 - responseJsonEither === const (Right expected) + getLegalHold = getFlag Public.TeamFeatureLegalHold getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getLegalHoldInternal expected = getLegalHoldEnabledInternal tid !!! do - statusCode === const 200 - responseJsonEither === const (Right expected) + getLegalHoldInternal = getFlagInternal Public.TeamFeatureLegalHold setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - setLegalHoldInternal = putLegalHoldEnabledInternal tid + setLegalHoldInternal = setFlagInternal Public.TeamFeatureLegalHold getLegalHold Public.TeamFeatureDisabled getLegalHoldInternal Public.TeamFeatureDisabled @@ -2022,6 +2023,11 @@ testFeatureFlags = do featureLegalHold <- view (tsGConf . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do + -- Test default + getLegalHold Public.TeamFeatureDisabled + getLegalHoldInternal Public.TeamFeatureDisabled + + -- Test override setLegalHoldInternal Public.TeamFeatureEnabled getLegalHold Public.TeamFeatureEnabled getLegalHoldInternal Public.TeamFeatureEnabled @@ -2077,6 +2083,16 @@ testFeatureFlags = do getTeamSearchVisibility tid3 Public.TeamFeatureEnabled getTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled + forM_ [Public.TeamFeatureDigitalSignatures, Public.TeamFeatureValidateSAMLEmails] $ \(feature) -> do + -- Disabled by default + getFlag feature Public.TeamFeatureDisabled + getFlagInternal feature Public.TeamFeatureDisabled + + -- Settting should work + setFlagInternal feature Public.TeamFeatureEnabled + getFlag feature Public.TeamFeatureEnabled + getFlagInternal feature Public.TeamFeatureEnabled + checkJoinEvent :: (MonadIO m, MonadCatch m) => TeamId -> UserId -> WS.WebSocket -> m () checkJoinEvent tid usr w = WS.assertMatch_ timeout w $ \notif -> do ntfTransient notif @?= False From 39620347f2a183b21cd010e5bb3ceafdd4ce20ac Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Wed, 10 Jun 2020 15:26:25 +0200 Subject: [PATCH 2/7] Add federation domain and federator endpoint to service configuration (#1133) * brig: supply backend's federation domain via configuration * galley: supply backend's federation domain via configuration * brig: configuration for talking to federator * galley: configuration for talking to federator --- services/brig/brig.integration.yaml | 7 ++++ services/brig/src/Brig/API/Util.hs | 15 +++++-- services/brig/src/Brig/Options.hs | 11 +++--- services/galley/galley.integration.yaml | 6 +++ services/galley/src/Galley/API/Util.hs | 52 ++++++++++++++----------- services/galley/src/Galley/Options.hs | 10 ++--- 6 files changed, 65 insertions(+), 36 deletions(-) diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 49b224fe855..ea46e2d1c1a 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -24,6 +24,10 @@ gundeck: host: 127.0.0.1 port: 8086 +# federator: +# host: 127.0.0.1 +# port: 8097 + # You can set up local SQS/Dynamo running e.g. `../../deploy/dockerephemeral/run.sh` aws: userJournalQueue: integration-user-events.fifo @@ -160,6 +164,9 @@ optSettings: # setUserMaxPermClients: 7 # ^ You can limit the max number of permanent clients that a user is allowed # to register, per account. The default value is '7' if the option is unset. + # enableFederationWithDomain: wire.com + # ^ This is used to qualify local IDs and handles, e.g. somehandle@wire.com. + # If you change it, remember to also update it for Galley. logLevel: Warn # ^ NOTE: We log too much in brig, if we set this to Info like other services, running tests diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index dc14075509b..9ea13da39ee 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -20,10 +20,11 @@ module Brig.API.Util where import Brig.API.Handler import Brig.App (Env, settings) import qualified Brig.Data.User as Data -import Brig.Options (defEnableFederation, enableFederation) +import Brig.Options (enableFederationWithDomain) import Brig.Types import Control.Lens (view) import Control.Monad +import Data.Domain (Domain) import Data.Id as Id import Data.IdMapping (MappedOrLocalId (Local)) import Data.Maybe @@ -36,13 +37,21 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us +-------------------------------------------------------------------------------- +-- Federation + +viewFederationDomain :: MonadReader Env m => m (Maybe Domain) +viewFederationDomain = view (settings . enableFederationWithDomain) + +isFederationEnabled :: MonadReader Env m => m Bool +isFederationEnabled = isJust <$> viewFederationDomain + -- FUTUREWORK(federation, #1178): implement function to resolve IDs in batch -- | this exists as a shim to find and mark places where we need to handle 'OpaqueUserId's. resolveOpaqueUserId :: MonadReader Env m => OpaqueUserId -> m (MappedOrLocalId Id.U) resolveOpaqueUserId (Id opaque) = do - mEnabled <- view (settings . enableFederation) - case fromMaybe defEnableFederation mEnabled of + isFederationEnabled >>= \case False -> -- don't check the ID mapping, just assume it's local pure . Local $ Id opaque diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 070d845c536..098879d30a0 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -329,6 +329,8 @@ data Opts = Opts galley :: !Endpoint, -- | Gundeck address gundeck :: !Endpoint, + -- | Federator address + federator :: !(Maybe Endpoint), -- external -- | Cassandra settings @@ -442,10 +444,10 @@ data Settings = Settings -- | When true, search only -- returns users from the same team setSearchSameTeamOnly :: !(Maybe Bool), - -- | When false, assume there are no other backends and IDs are always local. + -- | When @Nothing@, assume there are no other backends and IDs are always local. -- This means we don't run any queries on federation-related tables and don't -- make any calls to the federator service. - setEnableFederation :: !(Maybe Bool), + setEnableFederationWithDomain :: !(Maybe Domain), -- | The amount of time in milliseconds to wait after reading from an SQS queue -- returns no message, before asking for messages from SQS again. -- defaults to 'defSqsThrottleMillis'. @@ -521,9 +523,6 @@ defSqsThrottleMillis = 500 defUserMaxPermClients :: Int defUserMaxPermClients = 7 -defEnableFederation :: Bool -defEnableFederation = False - instance FromJSON Timeout where parseJSON (Y.Number n) = let defaultV = 3600 @@ -551,7 +550,7 @@ Lens.makeLensesFor ("setPropertyMaxValueLen", "propertyMaxValueLen"), ("setSearchSameTeamOnly", "searchSameTeamOnly"), ("setUserMaxPermClients", "userMaxPermClients"), - ("setEnableFederation", "enableFederation"), + ("setEnableFederationWithDomain", "enableFederationWithDomain"), ("setSqsThrottleMillis", "sqsThrottleMillis") ] ''Settings diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 956fc39397a..cff6b2b0c8b 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -20,6 +20,10 @@ spar: host: 127.0.0.1 port: 8088 +# federator: +# host: 127.0.0.1 +# port: 8097 + settings: httpPoolSize: 128 maxTeamSize: 32 @@ -30,6 +34,8 @@ settings: concurrentDeletionEvents: 1024 deleteConvThrottleMillis: 0 enableIndexedBillingTeamMembers: true + # enableFederationWithDomain: wire.com + # ^ if you change this, remember to also update it for Brig featureFlags: # see #RefConfigOptions in `/docs/reference` sso: disabled-by-default diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index ffb4a9aeb73..84a9d7497d8 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -22,6 +22,7 @@ import Brig.Types.Intra (ReAuthUser (..)) import Control.Lens ((.~), (^.), view) import Control.Monad.Catch import Data.ByteString.Conversion +import Data.Domain (Domain) import Data.Id as Id import Data.IdMapping (MappedOrLocalId (Local, Mapped), partitionMappedOrLocalIds) import Data.List.NonEmpty (nonEmpty) @@ -36,7 +37,7 @@ import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes import Galley.Intra.Push import Galley.Intra.User -import Galley.Options (defEnableFederation, optSettings, setEnableFederation) +import Galley.Options (optSettings, setEnableFederationWithDomain) import Galley.Types import Galley.Types.Conversations.Roles import Galley.Types.Teams @@ -259,13 +260,38 @@ getConversationAndCheckMembershipWithError ex zusr = \case throwM ex return c +-- | Deletion requires a permission check, but also a 'Role' comparison: +-- Owners can only be deleted by another owner (and not themselves). +-- +-- FUTUREWORK: do not do this with 'Role', but introduce permissions "can delete owner", "can +-- delete admin", etc. +canDeleteMember :: TeamMember -> TeamMember -> Bool +canDeleteMember deleter deletee + | getRole deletee == RoleOwner = + getRole deleter == RoleOwner -- owners can only be deleted by another owner + && (deleter ^. userId /= deletee ^. userId) -- owner cannot delete itself + | otherwise = + True + where + -- (team members having no role is an internal error, but we don't want to deal with that + -- here, so we pick a reasonable default.) + getRole mem = fromMaybe RoleMember $ permissionsRole $ mem ^. permissions + +-------------------------------------------------------------------------------- +-- Federation + +viewFederationDomain :: Galley (Maybe Domain) +viewFederationDomain = view (options . optSettings . setEnableFederationWithDomain) + +isFederationEnabled :: Galley Bool +isFederationEnabled = isJust <$> viewFederationDomain + -- FUTUREWORK(federation, #1178): implement function to resolve IDs in batch -- | this exists as a shim to find and mark places where we need to handle 'OpaqueUserId's. resolveOpaqueUserId :: OpaqueUserId -> Galley (MappedOrLocalId Id.U) resolveOpaqueUserId (Id opaque) = do - mEnabled <- view (options . optSettings . setEnableFederation) - case fromMaybe defEnableFederation mEnabled of + isFederationEnabled >>= \case False -> -- don't check the ID mapping, just assume it's local pure . Local $ Id opaque @@ -276,28 +302,10 @@ resolveOpaqueUserId (Id opaque) = do -- | this exists as a shim to find and mark places where we need to handle 'OpaqueConvId's. resolveOpaqueConvId :: OpaqueConvId -> Galley (MappedOrLocalId Id.C) resolveOpaqueConvId (Id opaque) = do - mEnabled <- view (options . optSettings . setEnableFederation) - case fromMaybe defEnableFederation mEnabled of + isFederationEnabled >>= \case False -> -- don't check the ID mapping, just assume it's local pure . Local $ Id opaque True -> -- FUTUREWORK(federation, #1178): implement database lookup pure . Local $ Id opaque - --- | Deletion requires a permission check, but also a 'Role' comparison: --- Owners can only be deleted by another owner (and not themselves). --- --- FUTUREWORK: do not do this with 'Role', but introduce permissions "can delete owner", "can --- delete admin", etc. -canDeleteMember :: TeamMember -> TeamMember -> Bool -canDeleteMember deleter deletee - | getRole deletee == RoleOwner = - getRole deleter == RoleOwner -- owners can only be deleted by another owner - && (deleter ^. userId /= deletee ^. userId) -- owner cannot delete itself - | otherwise = - True - where - -- (team members having no role is an internal error, but we don't want to deal with that - -- here, so we pick a reasonable default.) - getRole mem = fromMaybe RoleMember $ permissionsRole $ mem ^. permissions diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index aab05884306..079bae85332 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -19,6 +19,7 @@ module Galley.Options where import Control.Lens hiding ((.=), Level) import Data.Aeson.TH (deriveFromJSON) +import Data.Domain (Domain) import Data.Misc import Data.Range import Galley.Types.Teams (FeatureFlags (..), HardTruncationLimit, hardTruncationLimit) @@ -47,10 +48,10 @@ data Settings = Settings _setConcurrentDeletionEvents :: !(Maybe Int), -- | Throttling: delay between sending events upon team deletion _setDeleteConvThrottleMillis :: !(Maybe Int), - -- | When false, assume there are no other backends and IDs are always local. + -- | When @Nothing@, assume there are no other backends and IDs are always local. -- This means we don't run any queries on federation-related tables and don't -- make any calls to the federator service. - _setEnableFederation :: !(Maybe Bool), + _setEnableFederationWithDomain :: !(Maybe Domain), -- | When true, galley will assume data in `billing_team_member` table is -- consistent and use it for billing. -- When false, billing information for large teams is not guaranteed to have all @@ -74,9 +75,6 @@ defDeleteConvThrottleMillis = 20 defFanoutLimit :: Range 1 HardTruncationLimit Int32 defFanoutLimit = unsafeRange hardTruncationLimit -defEnableFederation :: Bool -defEnableFederation = False - data JournalOpts = JournalOpts { -- | SQS queue name to send team events _awsQueueName :: !Text, @@ -100,6 +98,8 @@ data Opts = Opts _optGundeck :: !Endpoint, -- | Spar endpoint _optSpar :: !Endpoint, + -- | Federator endpoint + _optFederator :: !(Maybe Endpoint), -- | Disco URL _optDiscoUrl :: !(Maybe Text), -- | Other settings From d0a83c429aa862ede62e4fec59ba676348f71218 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 10 Jun 2020 16:32:08 +0200 Subject: [PATCH 3/7] Refactor team feature tests (#1136) --- services/galley/galley.cabal | 4 +- services/galley/test/integration/API.hs | 4 +- services/galley/test/integration/API/Teams.hs | 212 +----------------- .../test/integration/API/Teams/Feature.hs | 175 +++++++++++++++ .../test/integration/API/Util/TeamFeature.hs | 77 +++++++ 5 files changed, 267 insertions(+), 205 deletions(-) create mode 100644 services/galley/test/integration/API/Teams/Feature.hs create mode 100644 services/galley/test/integration/API/Util/TeamFeature.hs diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 1a0c55e5ce4..2d2d22e2499 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 68e5113c1088325ae314f68dcfe34cc49353b1500f48dff408c8a045cf8d94c6 +-- hash: 95344a909a53f5c4aedff6805c8679acf34708259b5949d1b5f580509e8f1d58 name: galley version: 0.83.0 @@ -190,8 +190,10 @@ executable galley-integration API.Roles API.SQS API.Teams + API.Teams.Feature API.Teams.LegalHold API.Util + API.Util.TeamFeature TestHelpers TestSetup Paths_galley diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 135829d5d05..8bec226b6fd 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -27,6 +27,7 @@ import qualified API.MessageTimer as MessageTimer import qualified API.Roles as Roles import API.SQS import qualified API.Teams as Teams +import qualified API.Teams.Feature as TeamFeature import qualified API.Teams.LegalHold as Teams.LegalHold import API.Util import Bilge hiding (timeout) @@ -67,7 +68,8 @@ tests s = Teams.tests s, MessageTimer.tests s, Roles.tests s, - CustomBackend.tests s + CustomBackend.tests s, + TeamFeature.tests s ] where mainTests = diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 6da1d9c7d37..e0bdfe5f91f 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -25,6 +25,7 @@ where import API.SQS import API.Util import qualified API.Util as Util +import qualified API.Util.TeamFeature as Util import Bilge hiding (timeout) import Bilge.Assert import qualified Brig.Types as Brig @@ -57,7 +58,6 @@ import Galley.Types.Teams.SearchVisibility import Gundeck.Types.Notification hiding (target) import Imports import Network.HTTP.Types.Status (status403) -import qualified Network.Wai.Test as WaiTest import qualified Network.Wai.Utilities.Error as Error import qualified Network.Wai.Utilities.Error as Wai import qualified Proto.TeamEvents as E @@ -128,8 +128,7 @@ tests s = test s "post crypto broadcast message protobuf" postCryptoBroadcastMessageProto, test s "post crypto broadcast message redundant/missing" postCryptoBroadcastMessageJson2, test s "post crypto broadcast message no-team" postCryptoBroadcastMessageNoTeam, - test s "post crypto broadcast message 100 (or max conns)" postCryptoBroadcastMessage100OrMaxConns, - test s "feature flags" testFeatureFlags + test s "post crypto broadcast message 100 (or max conns)" postCryptoBroadcastMessage100OrMaxConns ] timeout :: WS.Timeout @@ -318,7 +317,7 @@ testEnableTeamSearchVisibilityPerTeam = do (tid, owner, (member : _)) <- Util.createBindingTeamWithMembers 2 let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatus -> m () check msg enabledness = do - status <- responseJsonUnsafe <$> (getTeamSearchVisibilityAvailableInternal g tid (Util.getTeamSearchVisibilityAvailableInternal g tid m () putSearchVisibilityCheckNotAllowed = do @@ -331,15 +330,15 @@ testEnableTeamSearchVisibilityPerTeam = do const 200 === statusCode const (Just (TeamSearchVisibilityView vis)) === responseJsonUnsafe - withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do + Util.withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do check "Teams should start with Custom Search Visibility enabled" Public.TeamFeatureEnabled putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam !!! const 204 === statusCode putSearchVisibility g owner tid SearchVisibilityStandard !!! const 204 === statusCode - withCustomSearchFeature FeatureTeamSearchVisibilityDisabledByDefault $ do + Util.withCustomSearchFeature FeatureTeamSearchVisibilityDisabledByDefault $ do check "Teams should start with Custom Search Visibility disabled" Public.TeamFeatureDisabled putSearchVisibilityCheckNotAllowed - putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureEnabled + Util.putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureEnabled -- Nothing was set, default value getSearchVisibilityCheck SearchVisibilityStandard putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam !!! testResponse 204 Nothing @@ -350,7 +349,7 @@ testEnableTeamSearchVisibilityPerTeam = do -- Members can also see it? getSearchVisibility g member tid !!! testResponse 200 Nothing -- Once we disable the feature, team setting is back to the default value - putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureDisabled + Util.putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureDisabled getSearchVisibilityCheck SearchVisibilityStandard testCreateOne2OneFailNonBindingTeamMembers :: TestM () @@ -1886,10 +1885,10 @@ newTeamMember' perms uid = newTeamMember uid perms Nothing -- and with different kinds of internal checks, it's quite tedious to do so. getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS -getSSOEnabledInternal = getTeamFeatureFlagInternal Public.TeamFeatureSSO +getSSOEnabledInternal = Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatus -> TestM () -putSSOEnabledInternal = putTeamFeatureFlagInternal' Public.TeamFeatureSSO expect2xx +putSSOEnabledInternal = Util.putTeamFeatureFlagInternal' Public.TeamFeatureSSO expect2xx getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS getSearchVisibility g uid tid = do @@ -1906,193 +1905,6 @@ putSearchVisibility g uid tid vis = do . zUser uid . json (TeamSearchVisibilityView vis) -getTeamSearchVisibilityAvailable :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS -getTeamSearchVisibilityAvailable = getTeamFeatureFlagWithGalley Public.TeamFeatureSearchVisibility - -getTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS -getTeamSearchVisibilityAvailableInternal = - getTeamFeatureFlagInternalWithGalley Public.TeamFeatureSearchVisibility - -putTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> (MonadIO m, MonadHttp m) => m () -putTeamSearchVisibilityAvailableInternal g = - putTeamFeatureFlagInternalWithGalleyAndMod Public.TeamFeatureSearchVisibility g expect2xx - -putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () -putLegalHoldEnabledInternal' = putTeamFeatureFlagInternal' Public.TeamFeatureLegalHold - -putTeamFeatureFlagInternal' :: HasCallStack => Public.TeamFeatureName -> (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () -putTeamFeatureFlagInternal' feature reqmod tid status = do - g <- view tsGalley - putTeamFeatureFlagInternalWithGalleyAndMod feature g reqmod tid status - -putTeamFeatureFlagInternalWithGalleyAndMod :: - (MonadIO m, MonadHttp m, HasCallStack) => - Public.TeamFeatureName -> - (Request -> Request) -> - (Request -> Request) -> - TeamId -> - Public.TeamFeatureStatus -> - m () -putTeamFeatureFlagInternalWithGalleyAndMod feature galley reqmod tid status = - void . put $ - galley - . paths ["i", "teams", toByteString' tid, "features", toByteString' feature] - . json status - . reqmod - -getTeamFeatureFlagInternal :: HasCallStack => Public.TeamFeatureName -> TeamId -> TestM ResponseLBS -getTeamFeatureFlagInternal feature tid = do - g <- view tsGalley - getTeamFeatureFlagInternalWithGalley feature g tid - -getTeamFeatureFlagInternalWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => Public.TeamFeatureName -> (Request -> Request) -> HasCallStack => TeamId -> m ResponseLBS -getTeamFeatureFlagInternalWithGalley feature g tid = do - get $ - g - . paths ["i", "teams", toByteString' tid, "features", toByteString' feature] - -getTeamFeatureFlag :: HasCallStack => Public.TeamFeatureName -> UserId -> TeamId -> TestM ResponseLBS -getTeamFeatureFlag feature uid tid = do - g <- view tsGalley - getTeamFeatureFlagWithGalley feature g uid tid - -getTeamFeatureFlagWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => Public.TeamFeatureName -> (Request -> Request) -> UserId -> TeamId -> m ResponseLBS -getTeamFeatureFlagWithGalley feature galley uid tid = do - get $ - galley - . paths ["teams", toByteString' tid, "features", toByteString' feature] - . zUser uid - -testFeatureFlags :: TestM () -testFeatureFlags = do - owner <- Util.randomUser - member <- Util.randomUser - tid <- Util.createNonBindingTeam "foo" owner [] - Util.connectUsers owner (list1 member []) - Util.addTeamMember owner tid (newTeamMember member (rolePermissions RoleMember) Nothing) - - -- Get/Set flag while expecting 200 - let getFlag :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () - getFlag feature expected = getTeamFeatureFlag feature member tid !!! do - statusCode === const 200 - responseJsonEither === const (Right expected) - getFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () - getFlagInternal feature expected = getTeamFeatureFlagInternal feature tid !!! do - statusCode === const 200 - responseJsonEither === const (Right expected) - setFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () - setFlagInternal feature = putTeamFeatureFlagInternal' feature expect2xx tid - - -- sso - - let getSSO :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getSSO = getFlag Public.TeamFeatureSSO - getSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getSSOInternal = getFlagInternal Public.TeamFeatureSSO - setSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - setSSOInternal = setFlagInternal Public.TeamFeatureSSO - featureSSO <- view (tsGConf . optSettings . setFeatureFlags . flagSSO) - case featureSSO of - FeatureSSODisabledByDefault -> do - -- Test default - getSSO Public.TeamFeatureDisabled - getSSOInternal Public.TeamFeatureDisabled - - -- Test override - setSSOInternal Public.TeamFeatureEnabled - getSSO Public.TeamFeatureEnabled - getSSOInternal Public.TeamFeatureEnabled - FeatureSSOEnabledByDefault -> do - -- since we don't allow to disable (see 'disableSsoNotImplemented'), we can't test - -- much here. (disable failure is covered in "enable/disable SSO" above.) - getSSO Public.TeamFeatureEnabled - getSSOInternal Public.TeamFeatureEnabled - - -- legalhold - - let getLegalHold :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getLegalHold = getFlag Public.TeamFeatureLegalHold - getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - getLegalHoldInternal = getFlagInternal Public.TeamFeatureLegalHold - setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () - setLegalHoldInternal = setFlagInternal Public.TeamFeatureLegalHold - getLegalHold Public.TeamFeatureDisabled - getLegalHoldInternal Public.TeamFeatureDisabled - - -- FUTUREWORK: run two galleys, like below for custom search visibility. - featureLegalHold <- view (tsGConf . optSettings . setFeatureFlags . flagLegalHold) - case featureLegalHold of - FeatureLegalHoldDisabledByDefault -> do - -- Test default - getLegalHold Public.TeamFeatureDisabled - getLegalHoldInternal Public.TeamFeatureDisabled - - -- Test override - setLegalHoldInternal Public.TeamFeatureEnabled - getLegalHold Public.TeamFeatureEnabled - getLegalHoldInternal Public.TeamFeatureEnabled - FeatureLegalHoldDisabledPermanently -> do - putLegalHoldEnabledInternal' expect4xx tid Public.TeamFeatureEnabled - - -- custom search visibility - - g <- view tsGalley - let getTeamSearchVisibility :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatus -> - m () - getTeamSearchVisibility teamid expected = getTeamSearchVisibilityAvailable g owner teamid !!! do - statusCode === const 200 - responseJsonEither === const (Right expected) - - let getTeamSearchVisibilityInternal :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatus -> - m () - getTeamSearchVisibilityInternal teamid expected = getTeamSearchVisibilityAvailableInternal g teamid !!! do - statusCode === const 200 - responseJsonEither === const (Right expected) - - let setTeamSearchVisibilityInternal :: - (Monad m, MonadHttp m, MonadIO m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatus -> - m () - setTeamSearchVisibilityInternal = putTeamSearchVisibilityAvailableInternal g - - tid2 <- Util.createNonBindingTeam "foo" owner [] - withCustomSearchFeature FeatureTeamSearchVisibilityDisabledByDefault $ do - getTeamSearchVisibility tid2 Public.TeamFeatureDisabled - getTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled - setTeamSearchVisibilityInternal tid2 Public.TeamFeatureEnabled - getTeamSearchVisibility tid2 Public.TeamFeatureEnabled - getTeamSearchVisibilityInternal tid2 Public.TeamFeatureEnabled - setTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled - getTeamSearchVisibility tid2 Public.TeamFeatureDisabled - getTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled - tid3 <- Util.createNonBindingTeam "foo" owner [] - withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do - getTeamSearchVisibility tid3 Public.TeamFeatureEnabled - getTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled - setTeamSearchVisibilityInternal tid3 Public.TeamFeatureDisabled - getTeamSearchVisibility tid3 Public.TeamFeatureDisabled - getTeamSearchVisibilityInternal tid3 Public.TeamFeatureDisabled - setTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled - getTeamSearchVisibility tid3 Public.TeamFeatureEnabled - getTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled - - forM_ [Public.TeamFeatureDigitalSignatures, Public.TeamFeatureValidateSAMLEmails] $ \(feature) -> do - -- Disabled by default - getFlag feature Public.TeamFeatureDisabled - getFlagInternal feature Public.TeamFeatureDisabled - - -- Settting should work - setFlagInternal feature Public.TeamFeatureEnabled - getFlag feature Public.TeamFeatureEnabled - getFlagInternal feature Public.TeamFeatureEnabled - checkJoinEvent :: (MonadIO m, MonadCatch m) => TeamId -> UserId -> WS.WebSocket -> m () checkJoinEvent tid usr w = WS.assertMatch_ timeout w $ \notif -> do ntfTransient notif @?= False @@ -2100,9 +1912,3 @@ checkJoinEvent tid usr w = WS.assertMatch_ timeout w $ \notif -> do e ^. eventType @?= MemberJoin e ^. eventTeam @?= tid e ^. eventData @?= Just (EdMemberJoin usr) - -withCustomSearchFeature :: FeatureTeamSearchVisibility -> WaiTest.Session () -> TestM () -withCustomSearchFeature flag action = do - opts <- view tsGConf - let opts' = opts & optSettings . setFeatureFlags . flagTeamSearchVisibility .~ flag - withSettingsOverrides opts' action diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs new file mode 100644 index 00000000000..7d6d10f8aea --- /dev/null +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -0,0 +1,175 @@ +module API.Teams.Feature (tests) where + +import qualified API.Util as Util +import qualified API.Util.TeamFeature as Util +import Bilge +import Bilge.Assert +import Control.Lens (view) +import Control.Monad.Catch (MonadCatch) +import Data.Id (TeamId) +import Data.List1 (list1) +import Galley.Options (optSettings, setFeatureFlags) +import Galley.Types.Teams +import Imports +import Test.Tasty +import TestHelpers (test) +import TestSetup +import qualified Wire.API.Team.Feature as Public +import qualified Wire.API.Team.Member as Public + +tests :: IO TestSetup -> TestTree +tests s = + testGroup "Team Features API" $ + [ test s "SSO" testSSO, + test s "LegalHold" testLegalHold, + test s "SearchVisibility" testSearchVisibility, + test s "DigitalSignatures" $ testSimpleFlag Public.TeamFeatureDigitalSignatures, + test s "ValidateSAMLEmails" $ testSimpleFlag Public.TeamFeatureValidateSAMLEmails + ] + +testSSO :: TestM () +testSSO = do + owner <- Util.randomUser + member <- Util.randomUser + tid <- Util.createNonBindingTeam "foo" owner [] + Util.connectUsers owner (list1 member []) + Util.addTeamMember owner tid (Public.newTeamMember member (rolePermissions RoleMember) Nothing) + + let getSSO :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getSSO = assertFlag $ Util.getTeamFeatureFlag Public.TeamFeatureSSO member tid + getSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getSSOInternal = assertFlag $ Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO tid + setSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + setSSOInternal = Util.putTeamFeatureFlagInternal' Public.TeamFeatureSSO expect2xx tid + featureSSO <- view (tsGConf . optSettings . setFeatureFlags . flagSSO) + case featureSSO of + FeatureSSODisabledByDefault -> do + -- Test default + getSSO Public.TeamFeatureDisabled + getSSOInternal Public.TeamFeatureDisabled + + -- Test override + setSSOInternal Public.TeamFeatureEnabled + getSSO Public.TeamFeatureEnabled + getSSOInternal Public.TeamFeatureEnabled + FeatureSSOEnabledByDefault -> do + -- since we don't allow to disable (see 'disableSsoNotImplemented'), we can't test + -- much here. (disable failure is covered in "enable/disable SSO" above.) + getSSO Public.TeamFeatureEnabled + getSSOInternal Public.TeamFeatureEnabled + +testLegalHold :: TestM () +testLegalHold = do + owner <- Util.randomUser + member <- Util.randomUser + tid <- Util.createNonBindingTeam "foo" owner [] + Util.connectUsers owner (list1 member []) + Util.addTeamMember owner tid (Public.newTeamMember member (rolePermissions RoleMember) Nothing) + + let getLegalHold :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getLegalHold = assertFlag $ Util.getTeamFeatureFlag Public.TeamFeatureLegalHold member tid + getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getLegalHoldInternal = assertFlag $ Util.getTeamFeatureFlagInternal Public.TeamFeatureLegalHold tid + setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + setLegalHoldInternal = Util.putTeamFeatureFlagInternal' Public.TeamFeatureLegalHold expect2xx tid + getLegalHold Public.TeamFeatureDisabled + getLegalHoldInternal Public.TeamFeatureDisabled + + -- FUTUREWORK: run two galleys, like below for custom search visibility. + featureLegalHold <- view (tsGConf . optSettings . setFeatureFlags . flagLegalHold) + case featureLegalHold of + FeatureLegalHoldDisabledByDefault -> do + -- Test default + getLegalHold Public.TeamFeatureDisabled + getLegalHoldInternal Public.TeamFeatureDisabled + + -- Test override + setLegalHoldInternal Public.TeamFeatureEnabled + getLegalHold Public.TeamFeatureEnabled + getLegalHoldInternal Public.TeamFeatureEnabled + FeatureLegalHoldDisabledPermanently -> do + Util.putLegalHoldEnabledInternal' expect4xx tid Public.TeamFeatureEnabled + +testSearchVisibility :: TestM () +testSearchVisibility = do + owner <- Util.randomUser + member <- Util.randomUser + tid <- Util.createNonBindingTeam "foo" owner [] + Util.connectUsers owner (list1 member []) + Util.addTeamMember owner tid (Public.newTeamMember member (rolePermissions RoleMember) Nothing) + + g <- view tsGalley + let getTeamSearchVisibility :: + (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => + TeamId -> + Public.TeamFeatureStatus -> + m () + getTeamSearchVisibility teamid expected = Util.getTeamSearchVisibilityAvailable g owner teamid !!! do + statusCode === const 200 + responseJsonEither === const (Right expected) + + let getTeamSearchVisibilityInternal :: + (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => + TeamId -> + Public.TeamFeatureStatus -> + m () + getTeamSearchVisibilityInternal teamid expected = Util.getTeamSearchVisibilityAvailableInternal g teamid !!! do + statusCode === const 200 + responseJsonEither === const (Right expected) + + let setTeamSearchVisibilityInternal :: + (Monad m, MonadHttp m, MonadIO m, HasCallStack) => + TeamId -> + Public.TeamFeatureStatus -> + m () + setTeamSearchVisibilityInternal = Util.putTeamSearchVisibilityAvailableInternal g + + tid2 <- Util.createNonBindingTeam "foo" owner [] + Util.withCustomSearchFeature FeatureTeamSearchVisibilityDisabledByDefault $ do + getTeamSearchVisibility tid2 Public.TeamFeatureDisabled + getTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled + setTeamSearchVisibilityInternal tid2 Public.TeamFeatureEnabled + getTeamSearchVisibility tid2 Public.TeamFeatureEnabled + getTeamSearchVisibilityInternal tid2 Public.TeamFeatureEnabled + setTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled + getTeamSearchVisibility tid2 Public.TeamFeatureDisabled + getTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled + tid3 <- Util.createNonBindingTeam "foo" owner [] + Util.withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do + getTeamSearchVisibility tid3 Public.TeamFeatureEnabled + getTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled + setTeamSearchVisibilityInternal tid3 Public.TeamFeatureDisabled + getTeamSearchVisibility tid3 Public.TeamFeatureDisabled + getTeamSearchVisibilityInternal tid3 Public.TeamFeatureDisabled + setTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled + getTeamSearchVisibility tid3 Public.TeamFeatureEnabled + getTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled + +testSimpleFlag :: Public.TeamFeatureName -> TestM () +testSimpleFlag feature = do + owner <- Util.randomUser + member <- Util.randomUser + tid <- Util.createNonBindingTeam "foo" owner [] + Util.connectUsers owner (list1 member []) + Util.addTeamMember owner tid (Public.newTeamMember member (rolePermissions RoleMember) Nothing) + + let getFlag :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + getFlag f expected = flip assertFlag expected $ Util.getTeamFeatureFlag f member tid + getFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + getFlagInternal f expected = flip assertFlag expected $ Util.getTeamFeatureFlagInternal f tid + setFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + setFlagInternal f = Util.putTeamFeatureFlagInternal' f expect2xx tid + + -- Disabled by default + getFlag feature Public.TeamFeatureDisabled + getFlagInternal feature Public.TeamFeatureDisabled + + -- Settting should work + setFlagInternal feature Public.TeamFeatureEnabled + getFlag feature Public.TeamFeatureEnabled + getFlagInternal feature Public.TeamFeatureEnabled + +assertFlag :: HasCallStack => TestM ResponseLBS -> Public.TeamFeatureStatus -> TestM () +assertFlag res expected = res !!! do + statusCode === const 200 + responseJsonEither === const (Right expected) diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs new file mode 100644 index 00000000000..8a5d1b71bff --- /dev/null +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -0,0 +1,77 @@ +module API.Util.TeamFeature where + +import qualified API.Util as Util +import API.Util (zUser) +import Bilge +import Control.Lens ((.~), view) +import Data.ByteString.Conversion (toByteString') +import Data.Id (TeamId, UserId) +import Galley.Options (optSettings, setFeatureFlags) +import Galley.Types.Teams +import Imports +import qualified Network.Wai.Test as WaiTest +import TestSetup +import qualified Wire.API.Team.Feature as Public + +withCustomSearchFeature :: FeatureTeamSearchVisibility -> WaiTest.Session () -> TestM () +withCustomSearchFeature flag action = do + opts <- view tsGConf + let opts' = opts & optSettings . setFeatureFlags . flagTeamSearchVisibility .~ flag + Util.withSettingsOverrides opts' action + +getTeamSearchVisibilityAvailable :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS +getTeamSearchVisibilityAvailable = getTeamFeatureFlagWithGalley Public.TeamFeatureSearchVisibility + +getTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS +getTeamSearchVisibilityAvailableInternal = + getTeamFeatureFlagInternalWithGalley Public.TeamFeatureSearchVisibility + +putTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> (MonadIO m, MonadHttp m) => m () +putTeamSearchVisibilityAvailableInternal g = + putTeamFeatureFlagInternalWithGalleyAndMod Public.TeamFeatureSearchVisibility g expect2xx + +putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () +putLegalHoldEnabledInternal' = putTeamFeatureFlagInternal' Public.TeamFeatureLegalHold + +putTeamFeatureFlagInternal' :: HasCallStack => Public.TeamFeatureName -> (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () +putTeamFeatureFlagInternal' feature reqmod tid status = do + g <- view tsGalley + putTeamFeatureFlagInternalWithGalleyAndMod feature g reqmod tid status + +putTeamFeatureFlagInternalWithGalleyAndMod :: + (MonadIO m, MonadHttp m, HasCallStack) => + Public.TeamFeatureName -> + (Request -> Request) -> + (Request -> Request) -> + TeamId -> + Public.TeamFeatureStatus -> + m () +putTeamFeatureFlagInternalWithGalleyAndMod feature galley reqmod tid status = + void . put $ + galley + . paths ["i", "teams", toByteString' tid, "features", toByteString' feature] + . json status + . reqmod + +getTeamFeatureFlagInternal :: HasCallStack => Public.TeamFeatureName -> TeamId -> TestM ResponseLBS +getTeamFeatureFlagInternal feature tid = do + g <- view tsGalley + getTeamFeatureFlagInternalWithGalley feature g tid + +getTeamFeatureFlagInternalWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => Public.TeamFeatureName -> (Request -> Request) -> HasCallStack => TeamId -> m ResponseLBS +getTeamFeatureFlagInternalWithGalley feature g tid = do + get $ + g + . paths ["i", "teams", toByteString' tid, "features", toByteString' feature] + +getTeamFeatureFlag :: HasCallStack => Public.TeamFeatureName -> UserId -> TeamId -> TestM ResponseLBS +getTeamFeatureFlag feature uid tid = do + g <- view tsGalley + getTeamFeatureFlagWithGalley feature g uid tid + +getTeamFeatureFlagWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => Public.TeamFeatureName -> (Request -> Request) -> UserId -> TeamId -> m ResponseLBS +getTeamFeatureFlagWithGalley feature galley uid tid = do + get $ + galley + . paths ["teams", toByteString' tid, "features", toByteString' feature] + . zUser uid From 4a0978f65b442fd8e4452086b96a7181d399525f Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Fri, 12 Jun 2020 19:40:54 +0200 Subject: [PATCH 4/7] Federation DB changes (#1070) This adapts two existing DB tables to make them work with federation: - `member`, which contains all members of a given conversation, now allows them to be remote. - `user`, which contains all conversations of a given user, now allows them to be remote. Following from that, a lot of code has to deal with the possibility of these things now not being local anymore, which is usually done by just separating the local and remote ones and bailing out if there are any remote ones. * cassandra-schema.cql: add missing field for digital signatures * add Remote Id type, use in IdMapping * Add remote identifier mapping to galley conversation-related tables * adapt queries on 'user' and 'member' table * Introduce InternalMember type * make everything compile again * update cassandra-schema.cql --- docs/reference/cassandra-schema.cql | 5 + libs/api-bot/src/Network/Wire/Bot/Assert.hs | 6 +- libs/galley-types/galley-types.cabal | 3 +- libs/galley-types/src/Galley/Types.hs | 88 +++--- .../src/Galley/Types/Conversations/Members.hs | 52 ++++ libs/types-common/src/Data/Domain.hs | 2 +- libs/types-common/src/Data/Id.hs | 8 + libs/types-common/src/Data/IdMapping.hs | 6 +- libs/types-common/src/Data/Qualified.hs | 2 +- .../src/Wire/API/Conversation/Member.hs | 4 +- services/brig/src/Brig/Provider/API.hs | 4 +- .../brig/test/integration/API/Provider.hs | 4 +- services/brig/test/integration/Util.hs | 4 +- services/galley/galley.cabal | 3 +- services/galley/schema/src/Main.hs | 4 +- .../schema/src/V44_AddRemoteIdentifiers.hs | 43 +++ services/galley/src/Galley/API/Create.hs | 6 +- services/galley/src/Galley/API/Error.hs | 5 +- services/galley/src/Galley/API/Internal.hs | 17 +- services/galley/src/Galley/API/Mapping.hs | 35 ++- services/galley/src/Galley/API/Query.hs | 31 ++- services/galley/src/Galley/API/Teams.hs | 34 ++- services/galley/src/Galley/API/Update.hs | 168 ++++++------ services/galley/src/Galley/API/Util.hs | 67 +++-- services/galley/src/Galley/Data.hs | 254 ++++++++++++------ services/galley/src/Galley/Data/Queries.hs | 41 ++- services/galley/src/Galley/Data/Services.hs | 9 +- services/galley/src/Galley/Data/Types.hs | 4 +- services/galley/src/Galley/Intra/Push.hs | 60 ++++- services/galley/test/integration/API.hs | 13 +- services/galley/test/integration/API/Util.hs | 11 +- 31 files changed, 650 insertions(+), 343 deletions(-) create mode 100644 libs/galley-types/src/Galley/Types/Conversations/Members.hs create mode 100644 services/galley/schema/src/V44_AddRemoteIdentifiers.hs diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 3a62c2e5288..b3fee71ab5b 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -103,6 +103,7 @@ CREATE TABLE galley_test.data_migration ( CREATE TABLE galley_test.team_features ( team_id uuid PRIMARY KEY, + digital_signatures int, legalhold_status int, search_visibility_status int, sso_status int, @@ -175,6 +176,8 @@ CREATE TABLE galley_test.member ( provider uuid, service uuid, status int, + user_remote_domain text, + user_remote_id uuid, PRIMARY KEY (conv, user) ) WITH CLUSTERING ORDER BY (user ASC) AND bloom_filter_fp_chance = 0.1 @@ -262,6 +265,8 @@ CREATE TABLE galley_test.meta ( CREATE TABLE galley_test.user ( user uuid, conv uuid, + conv_remote_domain text, + conv_remote_id uuid, PRIMARY KEY (user, conv) ) WITH CLUSTERING ORDER BY (conv ASC) AND bloom_filter_fp_chance = 0.1 diff --git a/libs/api-bot/src/Network/Wire/Bot/Assert.hs b/libs/api-bot/src/Network/Wire/Bot/Assert.hs index 83ace919c81..a0687f69950 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Assert.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Assert.hs @@ -20,7 +20,7 @@ module Network.Wire.Bot.Assert where -import Data.Id (ConvId, UserId) +import Data.Id (ConvId, UserId, makeIdOpaque) import qualified Data.Set as Set import Imports import Network.Wire.Bot.Monad @@ -39,7 +39,7 @@ assertConvCreated :: assertConvCreated c b bs = do let everyone = b : bs forM_ bs $ \u -> - let others = Set.fromList . filter (/= botId u) . map botId $ everyone + let others = Set.fromList . map makeIdOpaque . filter (/= botId u) . map botId $ everyone in assertEvent u TConvCreate (convCreate (botId u) others) where convCreate self others = \case @@ -50,7 +50,7 @@ assertConvCreated c b bs = do in cnvId cnv == c && convEvtFrom e == botId b && cnvType cnv == RegularConv - && memId (cmSelf mems) == self + && memId (cmSelf mems) == makeIdOpaque self && omems == others _ -> False diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 099894d2ddf..92b5a695603 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: fb74da023d3b1f2a3ad91fca661ee239b7010e42ec219bec603378749aafabea +-- hash: 73ad5a5126cffda9d353014c94e6f72b68f8dfbe7ecad75a7f03f55f13e06d7b name: galley-types version: 0.81.0 @@ -22,6 +22,7 @@ library Galley.Types Galley.Types.Bot Galley.Types.Bot.Service + Galley.Types.Conversations.Members Galley.Types.Conversations.Roles Galley.Types.Teams Galley.Types.Teams.Intra diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index 996e6b2ba94..c3804604311 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -24,7 +24,9 @@ module Galley.Types -- * re-exports Conversation (..), - Member (..), + LocalMember, + Member, + InternalMember (..), ConvMembers (..), OtherMember (..), Connect (..), @@ -75,8 +77,9 @@ import Data.Id (ClientId, ConvId, OpaqueUserId, TeamId, UserId) import Data.Json.Util ((#)) import qualified Data.Map.Strict as Map import Data.Misc (Milliseconds) +import Galley.Types.Conversations.Members (InternalMember (..), LocalMember, Member) import Imports -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member (..)) import Wire.API.Conversation.Code import Wire.API.Conversation.Typing import Wire.API.CustomBackend @@ -85,7 +88,8 @@ import Wire.API.Message import Wire.API.User (UserIdList (..)) import Wire.API.User.Client --- Conversations ------------------------------------------------------------ +-------------------------------------------------------------------------------- +-- ConversationMeta data ConversationMeta = ConversationMeta { cmId :: !ConvId, @@ -100,15 +104,34 @@ data ConversationMeta = ConversationMeta } deriving (Eq, Show) --------------------------------------------------------------------------------- +instance ToJSON ConversationMeta where + toJSON c = + object $ + "id" .= cmId c + # "type" .= cmType c + # "creator" .= cmCreator c + # "access" .= cmAccess c + # "access_role" .= cmAccessRole c + # "name" .= cmName c + # "team" .= cmTeam c + # "message_timer" .= cmMessageTimer c + # "receipt_mode" .= cmReceiptMode c + # [] -foldrOtrRecipients :: (OpaqueUserId -> ClientId -> Text -> a -> a) -> a -> OtrRecipients -> a -foldrOtrRecipients f a = - Map.foldrWithKey go a - . userClientMap - . otrRecipientsMap - where - go u cs acc = Map.foldrWithKey (f u) acc cs +instance FromJSON ConversationMeta where + parseJSON = withObject "conversation-meta" $ \o -> + ConversationMeta <$> o .: "id" + <*> o .: "type" + <*> o .: "creator" + <*> o .: "access" + <*> o .: "access_role" + <*> o .: "name" + <*> o .:? "team" + <*> o .:? "message_timer" + <*> o .:? "receipt_mode" + +-------------------------------------------------------------------------------- +-- Accept -- | Request payload for accepting a 1-1 conversation. newtype Accept = Accept @@ -116,40 +139,23 @@ newtype Accept = Accept } deriving (Eq, Show, Generic) --- Instances ---------------------------------------------------------------- - -instance FromJSON Accept where - parseJSON = withObject "accept" $ \o -> - Accept <$> o .: "user" - instance ToJSON Accept where toJSON a = object [ "user" .= aUser a ] -instance FromJSON ConversationMeta where - parseJSON = withObject "conversation-meta" $ \o -> - ConversationMeta <$> o .: "id" - <*> o .: "type" - <*> o .: "creator" - <*> o .: "access" - <*> o .: "access_role" - <*> o .: "name" - <*> o .:? "team" - <*> o .:? "message_timer" - <*> o .:? "receipt_mode" +instance FromJSON Accept where + parseJSON = withObject "accept" $ \o -> + Accept <$> o .: "user" -instance ToJSON ConversationMeta where - toJSON c = - object $ - "id" .= cmId c - # "type" .= cmType c - # "creator" .= cmCreator c - # "access" .= cmAccess c - # "access_role" .= cmAccessRole c - # "name" .= cmName c - # "team" .= cmTeam c - # "message_timer" .= cmMessageTimer c - # "receipt_mode" .= cmReceiptMode c - # [] +-------------------------------------------------------------------------------- +-- utility functions + +foldrOtrRecipients :: (OpaqueUserId -> ClientId -> Text -> a -> a) -> a -> OtrRecipients -> a +foldrOtrRecipients f a = + Map.foldrWithKey go a + . userClientMap + . otrRecipientsMap + where + go u cs acc = Map.foldrWithKey (f u) acc cs diff --git a/libs/galley-types/src/Galley/Types/Conversations/Members.hs b/libs/galley-types/src/Galley/Types/Conversations/Members.hs new file mode 100644 index 00000000000..b79488de5cc --- /dev/null +++ b/libs/galley-types/src/Galley/Types/Conversations/Members.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Types.Conversations.Members + ( LocalMember, + Member, + InternalMember (..), + ) +where + +import Data.Id as Id +import Data.IdMapping (MappedOrLocalId) +import Imports +import Wire.API.Conversation.Member (MutedStatus) +import Wire.API.Conversation.Role (RoleName) +import Wire.API.Provider.Service (ServiceRef) + +type LocalMember = InternalMember Id.UserId + +type Member = InternalMember (MappedOrLocalId Id.U) + +-- | Internal representation of a conversation member. +data InternalMember id = Member + { memId :: id, + memService :: Maybe ServiceRef, + -- | DEPRECATED, remove it once enough clients use `memOtrMutedStatus` + memOtrMuted :: Bool, + memOtrMutedStatus :: Maybe MutedStatus, + memOtrMutedRef :: Maybe Text, + memOtrArchived :: Bool, + memOtrArchivedRef :: Maybe Text, + memHidden :: Bool, + memHiddenRef :: Maybe Text, + memConvRoleName :: RoleName + } + deriving stock (Functor, Show) diff --git a/libs/types-common/src/Data/Domain.hs b/libs/types-common/src/Data/Domain.hs index 6573f9e1a18..fdbd5b51169 100644 --- a/libs/types-common/src/Data/Domain.hs +++ b/libs/types-common/src/Data/Domain.hs @@ -52,7 +52,7 @@ import Util.Attoparsec (takeUpToWhile) -- -- The domain will be normalized to lowercase when parsed. newtype Domain = Domain {_domainText :: Text} - deriving (Eq, Generic, Show) + deriving stock (Eq, Ord, Generic, Show) domainText :: Domain -> Text domainText = _domainText diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 783dc214d07..bc8074d6ab3 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -70,6 +70,8 @@ data Mapped a data Opaque a +data Remote a + type AssetId = Id A type InvitationId = Id I @@ -77,6 +79,9 @@ type InvitationId = Id I -- | A local conversation ID type ConvId = Id C +-- | A UUID local to another backend, only meaningful together with its domain. +type RemoteConvId = Id (Remote C) + -- | A UUID local to this backend, for which we know a mapping to a -- remote qualified conversation ID exists. -- These IDs should never leak to other backends or their clients. @@ -91,6 +96,9 @@ type OpaqueConvId = Id (Opaque C) -- | A local user ID type UserId = Id U +-- | A UUID local to another backend, only meaningful together with its domain. +type RemoteUserId = Id (Remote U) + -- | A UUID local to this backend, for which we know a mapping to a -- remote qualified user ID exists. -- These IDs should never leak to other backends or their clients. diff --git a/libs/types-common/src/Data/IdMapping.hs b/libs/types-common/src/Data/IdMapping.hs index 9eed06dcd26..9a27fa3413e 100644 --- a/libs/types-common/src/Data/IdMapping.hs +++ b/libs/types-common/src/Data/IdMapping.hs @@ -27,7 +27,7 @@ import Test.QuickCheck (Arbitrary (arbitrary), oneof) data MappedOrLocalId a = Mapped (IdMapping a) | Local (Id a) - deriving (Show) + deriving stock (Eq, Ord, Show) opaqueIdFromMappedOrLocal :: MappedOrLocalId a -> Id (Opaque a) opaqueIdFromMappedOrLocal = \case @@ -41,9 +41,9 @@ partitionMappedOrLocalIds = foldMap $ \case data IdMapping a = IdMapping { idMappingLocal :: Id (Mapped a), - idMappingGlobal :: Qualified (Id a) + idMappingGlobal :: Qualified (Id (Remote a)) } - deriving (Show) + deriving stock (Eq, Ord, Show) ---------------------------------------------------------------------- -- ARBITRARY diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 117971f3403..f9ad5f06787 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -92,7 +92,7 @@ data Qualified a = Qualified { _qLocalPart :: a, _qDomain :: Domain } - deriving (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) renderQualified :: (a -> Text) -> Qualified a -> Text renderQualified renderLocal (Qualified localPart domain) = diff --git a/libs/wire-api/src/Wire/API/Conversation/Member.hs b/libs/wire-api/src/Wire/API/Conversation/Member.hs index 55012a5bdc2..1dbf7bde868 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Member.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Member.hs @@ -83,7 +83,7 @@ instance FromJSON ConvMembers where -- Members data Member = Member - { memId :: UserId, + { memId :: OpaqueUserId, memService :: Maybe ServiceRef, -- | DEPRECATED, remove it once enough clients use `memOtrMutedStatus` memOtrMuted :: Bool, @@ -165,7 +165,7 @@ newtype MutedStatus = MutedStatus {fromMutedStatus :: Int32} deriving newtype (Num, FromJSON, ToJSON, Arbitrary) data OtherMember = OtherMember - { omId :: UserId, + { omId :: OpaqueUserId, omService :: Maybe ServiceRef, omConvRoleName :: RoleName } diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index ce8f6c393b9..d72d16131da 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -835,7 +835,7 @@ addBot zuid zcon cid add = do btk <- Text.decodeLatin1 . toByteString' <$> ZAuth.newBotToken pid bid cid let bcl = newClientId (fromIntegral (hash bid)) -- Ask the external service to create a bot - let origmem = OtherMember zuid Nothing roleNameWireAdmin + let origmem = OtherMember (makeIdOpaque zuid) Nothing roleNameWireAdmin let members = origmem : (cmOthers mems) let bcnv = Ext.botConvView (cnvId cnv) (cnvName cnv) members let busr = mkBotUserView zusr @@ -885,7 +885,7 @@ removeBot zusr zcon cid bid = do throwStd invalidConv -- Find the bot in the member list and delete it let busr = botUserId bid - let bot = List.find ((== busr) . omId) (cmOthers mems) + let bot = List.find ((== makeIdOpaque busr) . omId) (cmOthers mems) case bot >>= omService of Nothing -> return Nothing Just _ -> do diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index fe2722981c2..5ece933fc94 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1938,12 +1938,12 @@ testMessageBotUtil uid uc cid pid sid sref buf brig galley cannon = do let Just bcnv = responseJsonMaybe _rs liftIO $ do assertEqual "id" cid (bcnv ^. Ext.botConvId) - assertEqual "members" [OtherMember uid Nothing roleNameWireAdmin] (bcnv ^. Ext.botConvMembers) + assertEqual "members" [OtherMember (makeIdOpaque uid) Nothing roleNameWireAdmin] (bcnv ^. Ext.botConvMembers) -- The user can identify the bot in the member list mems <- fmap cnvMembers . responseJsonError =<< getConversation galley uid cid let other = listToMaybe (cmOthers mems) liftIO $ do - assertEqual "id" (Just buid) (omId <$> other) + assertEqual "id" (Just (makeIdOpaque buid)) (omId <$> other) assertEqual "service" (Just sref) (omService =<< other) -- The bot greets the user WS.bracketR cannon uid $ \ws -> do diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index f86bc9b3087..e023f701c68 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -53,7 +53,6 @@ import qualified Data.Text as Text import qualified Data.Text.Ascii as Ascii import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID -import Galley.Types (Member (..)) import qualified Galley.Types.Teams as Team import Gundeck.Types.Notification import Imports @@ -64,6 +63,7 @@ import Test.Tasty.Cannon import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import Util.AWS +import Wire.API.Conversation.Member (Member (..)) type Brig = Request -> Request @@ -475,7 +475,7 @@ isMember g usr cnv = do . expect2xx case responseJsonMaybe res of Nothing -> return False - Just m -> return (usr == memId m) + Just m -> return (makeIdOpaque usr == memId m) getStatus :: HasCallStack => Brig -> UserId -> (MonadIO m, MonadHttp m) => m AccountStatus getStatus brig u = diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 2d2d22e2499..bad590ab149 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 95344a909a53f5c4aedff6805c8679acf34708259b5949d1b5f580509e8f1d58 +-- hash: 0078da3c962467f70b278c32cbc35b9daca407ca541f11862b2262160c86c27b name: galley version: 0.83.0 @@ -339,6 +339,7 @@ executable galley-schema V41_TeamNotificationQueue V42_TeamFeatureValidateSamlEmails V43_TeamFeatureDigitalSignatures + V44_AddRemoteIdentifiers Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index df169403b7d..47eb0876e62 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -46,6 +46,7 @@ import qualified V40_CreateTableDataMigration import qualified V41_TeamNotificationQueue import qualified V42_TeamFeatureValidateSamlEmails import qualified V43_TeamFeatureDigitalSignatures +import qualified V44_AddRemoteIdentifiers main :: IO () main = do @@ -77,7 +78,8 @@ main = do V40_CreateTableDataMigration.migration, V41_TeamNotificationQueue.migration, V42_TeamFeatureValidateSamlEmails.migration, - V43_TeamFeatureDigitalSignatures.migration + V43_TeamFeatureDigitalSignatures.migration, + V44_AddRemoteIdentifiers.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Data ] diff --git a/services/galley/schema/src/V44_AddRemoteIdentifiers.hs b/services/galley/schema/src/V44_AddRemoteIdentifiers.hs new file mode 100644 index 00000000000..0e6894cbb67 --- /dev/null +++ b/services/galley/schema/src/V44_AddRemoteIdentifiers.hs @@ -0,0 +1,43 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V44_AddRemoteIdentifiers (migration) where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 44 "Add remote identifiers to conversation related tables" $ do + -- The user table answers the question: Which conversations am I a member of? + -- With federation one now also needs to know: Where are these conversations located? + schema' + [r| + ALTER TABLE user ADD ( + conv_remote_id uuid, + conv_remote_domain text + ); + |] + -- The member table is used to answer the question: Which users are part of a conversation? + -- With federation one now also needs to know: Where are these users located? + schema' + [r| + ALTER TABLE member ADD ( + user_remote_id uuid, + user_remote_domain text + ); + |] diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index a369c915364..1da97485edd 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -235,7 +235,7 @@ createConnectConversation usr conn j = do update n conv = let mems = Data.convMembers conv in conversationExisted usr - =<< if | makeIdOpaque usr `isMember` mems -> + =<< if | Local usr `isMember` mems -> -- we already were in the conversation, maybe also other connect n conv | otherwise -> do @@ -280,10 +280,10 @@ data ConversationResponse | ConversationExisted !Public.Conversation conversationCreated :: UserId -> Data.Conversation -> Galley ConversationResponse -conversationCreated usr cnv = ConversationCreated <$> conversationView usr cnv +conversationCreated usr cnv = ConversationCreated <$> conversationView (Local usr) cnv conversationExisted :: UserId -> Data.Conversation -> Galley ConversationResponse -conversationExisted usr cnv = ConversationExisted <$> conversationView usr cnv +conversationExisted usr cnv = ConversationExisted <$> conversationView (Local usr) cnv handleConversationResponse :: ConversationResponse -> Response handleConversationResponse = \case diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 76d7bde300b..55f013a2aaa 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -33,7 +33,10 @@ import Network.Wai.Utilities.Error import Type.Reflection (Typeable, typeRep) internalError :: Error -internalError = Error status500 "internal-error" "internal error" +internalError = internalErrorWithDescription "internal error" + +internalErrorWithDescription :: LText -> Error +internalErrorWithDescription = Error status500 "internal-error" convNotFound :: Error convNotFound = Error status404 "no-conversation" "conversation not found" diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 4764e27e3db..6abbf10c55e 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -26,7 +26,7 @@ import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) import Control.Monad.Catch (MonadCatch, throwM) -import Data.Id +import Data.Id as Id import Data.IdMapping (MappedOrLocalId (Local), partitionMappedOrLocalIds) import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1, list1, maybeList1) @@ -40,7 +40,7 @@ import qualified Galley.API.Query as Query import Galley.API.Teams (uncheckedDeleteTeamMember) import qualified Galley.API.Teams as Teams import qualified Galley.API.Update as Update -import Galley.API.Util (isMember, resolveOpaqueConvId) +import Galley.API.Util (isMember) import Galley.App import qualified Galley.Data as Data import qualified Galley.Intra.Push as Intra @@ -251,7 +251,7 @@ rmUser user conn = do let n = unsafeRange 100 :: Range 1 100 Int32 tids <- Data.teamIdsForPagination user Nothing (rcast n) leaveTeams tids - cids <- Data.conversationIdsForPagination user Nothing (rcast n) + cids <- Data.conversationIdRowsForPagination user Nothing (rcast n) let u = list1 user [] leaveConversations u cids Data.eraseClients user @@ -260,9 +260,10 @@ rmUser user conn = do mems <- Data.teamMembersForFanout tid uncheckedDeleteTeamMember user conn tid user mems leaveTeams =<< Cql.liftClient (Cql.nextPage tids) - leaveConversations :: List1 UserId -> Cql.Page OpaqueConvId -> Galley () + leaveConversations :: List1 UserId -> Cql.Page (Data.MappedOrLocalIdRow Id.C) -> Galley () leaveConversations u ids = do - (localConvIds, remoteConvIds) <- partitionMappedOrLocalIds <$> traverse resolveOpaqueConvId (Cql.result ids) + (localConvIds, remoteConvIds) <- + partitionMappedOrLocalIds <$> traverse Data.toMappedOrLocalId (Cql.result ids) -- FUTUREWORK(federation, #1275): leave remote conversations. -- If we could just get all conversation IDs at once and then leave conversations -- in batches, it would make everything much easier. @@ -271,10 +272,10 @@ rmUser user conn = do cc <- Data.conversations localConvIds pp <- for cc $ \c -> case Data.convType c of SelfConv -> return Nothing - One2OneConv -> Data.removeMember user (Data.convId c) >> return Nothing - ConnectConv -> Data.removeMember user (Data.convId c) >> return Nothing + One2OneConv -> Data.removeMember (Local user) (Data.convId c) >> return Nothing + ConnectConv -> Data.removeMember (Local user) (Data.convId c) >> return Nothing RegularConv - | isMember (makeIdOpaque user) (Data.convMembers c) -> do + | Local user `isMember` Data.convMembers c -> do e <- Data.removeMembers c user (Local <$> u) return $ (Intra.newPush ListComplete (evtFrom e) (Intra.ConvEvent e) (Intra.recipient <$> Data.convMembers c)) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index d22dd7c20bc..fea6328ae7f 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -20,11 +20,14 @@ module Galley.API.Mapping where import Control.Monad.Catch -import Data.ByteString.Conversion -import Data.Id +import Data.Id (idToText) +import qualified Data.Id as Id +import Data.IdMapping (IdMapping (IdMapping, idMappingGlobal, idMappingLocal), MappedOrLocalId (Local, Mapped), opaqueIdFromMappedOrLocal) import qualified Data.List as List +import Data.Qualified (renderQualifiedId) import Galley.App import qualified Galley.Data as Data +import qualified Galley.Types.Conversations.Members as Internal import Imports import Network.HTTP.Types.Status import Network.Wai.Utilities.Error @@ -32,25 +35,35 @@ import qualified System.Logger.Class as Log import System.Logger.Message ((+++), msg, val) import qualified Wire.API.Conversation as Public -conversationView :: UserId -> Data.Conversation -> Galley Public.Conversation +conversationView :: MappedOrLocalId Id.U -> Data.Conversation -> Galley Public.Conversation conversationView u Data.Conversation {..} = do let mm = toList convMembers - let (me, them) = List.partition ((u ==) . Public.memId) mm + let (me, them) = List.partition ((u ==) . Internal.memId) mm m <- maybe memberNotFound return (listToMaybe me) - let (name, mems) = (convName, Public.ConvMembers m (map toOther them)) - return $! Public.Conversation convId convType convCreator convAccess convAccessRole name mems convTeam convMessageTimer convReceiptMode + let mems = Public.ConvMembers (toMember m) (toOther <$> them) + return $! Public.Conversation convId convType convCreator convAccess convAccessRole convName mems convTeam convMessageTimer convReceiptMode where + toOther :: Internal.Member -> Public.OtherMember toOther x = Public.OtherMember - { omId = Public.memId x, - omService = Public.memService x, - omConvRoleName = Public.memConvRoleName x + { Public.omId = opaqueIdFromMappedOrLocal (Internal.memId x), + Public.omService = Internal.memService x, + Public.omConvRoleName = Internal.memConvRoleName x } memberNotFound = do Log.err . msg $ val "User " - +++ toByteString u + +++ showUserId u +++ val " is not a member of conv " - +++ toByteString convId + +++ idToText convId throwM badState + showUserId = \case + Local localId -> + idToText localId <> " (local)" + Mapped IdMapping {idMappingLocal, idMappingGlobal} -> + idToText idMappingLocal <> " (" <> renderQualifiedId idMappingGlobal <> ")" badState = Error status500 "bad-state" "Bad internal member state." + +toMember :: Internal.Member -> Public.Member +toMember x@(Internal.Member {..}) = + Public.Member {memId = opaqueIdFromMappedOrLocal (Internal.memId x), ..} diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index e332e0e94bf..660961f71b7 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -28,11 +28,11 @@ module Galley.API.Query where import Data.ByteString.Conversion -import Data.Id -import Data.IdMapping (MappedOrLocalId (Local), partitionMappedOrLocalIds) +import Data.Id as Id +import Data.IdMapping (MappedOrLocalId (Local), opaqueIdFromMappedOrLocal, partitionMappedOrLocalIds) import Data.Range import Galley.API.Error -import Galley.API.Mapping +import qualified Galley.API.Mapping as Mapping import Galley.API.Util import Galley.App import qualified Galley.Data as Data @@ -59,8 +59,10 @@ getBotConversation zbot zcnv = do pure $ Public.botConvView zcnv (Data.convName c) cmems where mkMember m - | memId m /= botUserId zbot = Just (OtherMember (memId m) (memService m) (memConvRoleName m)) - | otherwise = Nothing + | memId m == Local (botUserId zbot) = + Nothing -- no need to list the bot itself + | otherwise = + Just (OtherMember (opaqueIdFromMappedOrLocal (memId m)) (memService m) (memConvRoleName m)) getConversationH :: UserId ::: OpaqueConvId ::: JSON -> Galley Response getConversationH (zusr ::: cnv ::: _) = do @@ -70,7 +72,7 @@ getConversation :: UserId -> OpaqueConvId -> Galley Public.Conversation getConversation zusr opaqueCnv = do cnv <- resolveOpaqueConvId opaqueCnv c <- getConversationAndCheckMembership zusr cnv - conversationView zusr c + Mapping.conversationView (Local zusr) c getConversationRolesH :: UserId ::: OpaqueConvId ::: JSON -> Galley Response getConversationRolesH (zusr ::: cnv ::: _) = do @@ -90,10 +92,10 @@ getConversationIdsH (zusr ::: start ::: size ::: _) = do getConversationIds :: UserId -> Maybe OpaqueConvId -> Range 1 1000 Int32 -> Galley (Public.ConversationList OpaqueConvId) getConversationIds zusr start size = do - ids <- Data.conversationIdsFrom zusr start size + ids <- Data.conversationIdRowsFrom zusr start size pure $ Public.ConversationList - (Data.resultSetResult ids) + ((\(i, _, _) -> i) <$> Data.resultSetResult ids) (Data.resultSetType ids == Data.ResultSetTruncated) getConversationsH :: UserId ::: Maybe (Either (Range 1 32 (List OpaqueConvId)) OpaqueConvId) ::: Range 1 500 Int32 ::: JSON -> Galley Response @@ -103,13 +105,13 @@ getConversationsH (zusr ::: range ::: size ::: _) = getConversations :: UserId -> Maybe (Either (Range 1 32 (List OpaqueConvId)) OpaqueConvId) -> Range 1 500 Int32 -> Galley (Public.ConversationList Public.Conversation) getConversations zusr range size = withConvIds zusr range size $ \more ids -> do - (localConvIds, _qualifiedConvIds) <- partitionMappedOrLocalIds <$> traverse resolveOpaqueConvId ids + let (localConvIds, _qualifiedConvIds) = partitionMappedOrLocalIds ids -- FUTUREWORK(federation, #1273): fetch remote conversations from other backend cs <- Data.conversations localConvIds >>= filterM removeDeleted - >>= filterM (pure . isMember (makeIdOpaque zusr) . Data.convMembers) - flip Public.ConversationList more <$> mapM (conversationView zusr) cs + >>= filterM (pure . isMember (Local zusr) . Data.convMembers) + flip Public.ConversationList more <$> mapM (Mapping.conversationView (Local zusr)) cs where removeDeleted c | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False @@ -127,11 +129,12 @@ internalGetMemberH :: ConvId ::: UserId -> Galley Response internalGetMemberH (cnv ::: usr) = do json <$> internalGetMember cnv usr -internalGetMember :: ConvId -> UserId -> Galley (Maybe Member) +internalGetMember :: ConvId -> UserId -> Galley (Maybe Public.Member) internalGetMember cnv usr = do alive <- Data.isConvAlive cnv if alive - then Data.member cnv usr + then do + fmap Mapping.toMember <$> Data.member cnv usr else do Data.deleteConversation cnv pure Nothing @@ -168,7 +171,7 @@ withConvIds :: UserId -> Maybe (Either (Range 1 32 (List OpaqueConvId)) OpaqueConvId) -> Range 1 500 Int32 -> - (Bool -> [OpaqueConvId] -> Galley a) -> + (Bool -> [MappedOrLocalId Id.C] -> Galley a) -> Galley a withConvIds usr range size k = case range of Nothing -> do diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index b883a53436e..611b07e8089 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -62,7 +62,9 @@ import Brig.Types.Team (TeamSize (..)) import Control.Lens import Control.Monad.Catch import Data.ByteString.Conversion hiding (fromList) +import qualified Data.Id as Id import Data.Id +import Data.IdMapping (MappedOrLocalId (Local)) import qualified Data.List.Extra as List import Data.List1 (list1) import Data.Range as Range @@ -241,7 +243,7 @@ updateTeam zusr zcon tid updateData = do now <- liftIO getCurrentTime memList <- Data.teamMembersForFanout tid let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate updateData) - let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) + let r = list1 (userRecipient (Local zusr)) (membersToRecipients (Just zusr) (memList ^. teamMembers)) push1 $ newPush1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley Response @@ -309,7 +311,7 @@ uncheckedDeleteTeam zusr zcon tid = do pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley () pushDeleteEvents membs e ue = do o <- view $ options . optSettings - let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) membs) + let r = list1 (userRecipient (Local zusr)) (membersToRecipients (Just zusr) membs) -- To avoid DoS on gundeck, send team deletion events in chunks let chunkSize = fromMaybe defConcurrentDeletionEvents (o ^. setConcurrentDeletionEvents) let chunks = List.chunksOf chunkSize (toList r) @@ -331,7 +333,7 @@ uncheckedDeleteTeam zusr zcon tid = do ([Push], [(BotMember, Conv.Event)]) -> Galley ([Push], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do - (bots, convMembs) <- botsAndUsers <$> Data.members (c ^. conversationId) + (bots, convMembs) <- botsAndUsers =<< Data.members (c ^. conversationId) -- Only nonTeamMembers need to get any events, since on team deletion, -- all team users are deleted immediately after these events are sent -- and will thus never be able to see these events in practice. @@ -596,7 +598,7 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do pushMemberLeaveEvent :: UTCTime -> Galley () pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData .~ Just (EdMemberLeave remove) - let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) + let r = list1 (userRecipient (Local zusr)) (membersToRecipients (Just zusr) (mems ^. teamMembers)) push1 $ newPush1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley () @@ -604,18 +606,18 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do -- This may not make sense if that list has been truncated. In such cases, we still want to -- remove the user from conversations but never send out any events. We assume that clients -- handle nicely these missing events, regardless of whether they are in the same team or not - let tmids = Set.fromList $ map (view userId) (mems ^. teamMembers) + let tmids = Set.fromList $ map (Local . view userId) (mems ^. teamMembers) let edata = Conv.EdMembersLeave (Conv.UserIdList [remove]) cc <- Data.teamConversations tid for_ cc $ \c -> Data.conversation (c ^. conversationId) >>= \conv -> - for_ conv $ \dc -> when (makeIdOpaque remove `isMember` Data.convMembers dc) $ do - Data.removeMember remove (c ^. conversationId) + for_ conv $ \dc -> when (Local remove `isMember` Data.convMembers dc) $ do + Data.removeMember (Local remove) (c ^. conversationId) -- If the list was truncated, then the tmids list is incomplete so we simply drop these events unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc - pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley () + pushEvent :: Set (MappedOrLocalId Id.U) -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley () pushEvent exceptTo edata now dc = do - let (bots, users) = botsAndUsers (Data.convMembers dc) + (bots, users) <- botsAndUsers (Data.convMembers dc) let x = filter (\m -> not (Conv.memId m `Set.member` exceptTo)) users let y = Conv.Event Conv.MemberLeave (Data.convId dc) zusr now (Just edata) for_ (newPush (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> @@ -651,7 +653,7 @@ deleteTeamConversationH (zusr ::: zcon ::: tid ::: cid ::: _) = do deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley () deleteTeamConversation zusr zcon tid cid = do - (bots, cmems) <- botsAndUsers <$> Data.members cid + (bots, cmems) <- botsAndUsers =<< Data.members cid ensureActionAllowed Roles.DeleteConversation =<< getSelfMember zusr cmems flip Data.deleteCode Data.ReusableCode =<< Data.mkKey cid now <- liftIO getCurrentTime @@ -769,8 +771,14 @@ addTeamMemberInternal tid origin originConn newMem memList = do APITeamQueue.pushTeamEvent tid e return sizeBeforeAdd where - recipients (Just o) n = list1 (userRecipient o) (membersToRecipients (Just o) (n : memList ^. teamMembers)) - recipients Nothing n = list1 (userRecipient (n ^. userId)) (membersToRecipients Nothing (memList ^. teamMembers)) + recipients (Just o) n = + list1 + (userRecipient (Local o)) + (membersToRecipients (Just o) (n : memList ^. teamMembers)) + recipients Nothing n = + list1 + (userRecipient (Local (n ^. userId))) + (membersToRecipients Nothing (memList ^. teamMembers)) -- | See also: 'Gundeck.API.Public.paginateH', but the semantics of this end-point is slightly -- less warped. This is a work-around because we cannot send events to all of a large team. @@ -807,7 +815,7 @@ finishCreateTeam team owner others zcon = do now <- liftIO getCurrentTime let e = newEvent TeamCreate (team ^. teamId) now & eventData ?~ EdTeamCreate team let r = membersToRecipients Nothing others - push1 $ newPush1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon + push1 $ newPush1 ListComplete zusr (TeamEvent e) (list1 (userRecipient (Local zusr)) r) & pushConn .~ zcon withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b withBindingTeam zusr callback = do diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index c0c1d45b575..4c3c1c3edae 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -60,8 +60,8 @@ import Control.Monad.Catch import Control.Monad.State import Data.Code import Data.Id +import qualified Data.Id as Id import Data.IdMapping -import Data.List (delete) import Data.List.Extra (nubOrdOn) import Data.List.NonEmpty (nonEmpty) import Data.List1 @@ -109,7 +109,7 @@ acceptConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation acceptConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound conv' <- acceptOne2One usr conv conn - conversationView usr conv' + conversationView (Local usr) conv' blockConvH :: UserId ::: ConvId -> Galley Response blockConvH (zusr ::: cnv) = do @@ -122,7 +122,7 @@ blockConv zusr cnv = do $ throwM $ invalidOp "block: invalid conversation type" let mems = Data.convMembers conv - when (makeIdOpaque zusr `isMember` mems) $ Data.removeMember zusr cnv + when (Local zusr `isMember` mems) $ Data.removeMember (Local zusr) cnv unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response unblockConvH (usr ::: conn ::: cnv) = do @@ -135,7 +135,7 @@ unblockConv usr conn cnv = do $ throwM $ invalidOp "unblock: invalid conversation type" conv' <- acceptOne2One usr conv conn - conversationView usr conv' + conversationView (Local usr) conv' -- conversation updates @@ -163,7 +163,7 @@ updateConversationAccess usr zcon cnv update = do when (PrivateAccess `elem` targetAccess || PrivateAccessRole == targetRole) $ throwM invalidTargetAccess -- The user who initiated access change has to be a conversation member - (bots, users) <- botsAndUsers <$> Data.members cnv + (bots, users) <- botsAndUsers =<< Data.members cnv ensureConvMember users usr conv <- Data.conversation cnv >>= ifNothing convNotFound -- The conversation has to be a group conversation @@ -227,13 +227,20 @@ uncheckedUpdateConversationAccess body usr zcon conv (currentAccess, targetAcces -- based on those assumptions. when (currentRole > ActivatedAccessRole && targetRole <= ActivatedAccessRole) $ do mIds <- map memId <$> use usersL - activated <- fmap User.userId <$> lift (lookupActivatedUsers mIds) - usersL %= filter (\user -> memId user `elem` activated) + let (localMemberIds, _) = partitionMappedOrLocalIds mIds + activated <- fmap User.userId <$> lift (lookupActivatedUsers localMemberIds) + let isActivatedOrRemote user = case memId user of + Local l -> l `elem` activated + Mapped _ -> True -- remote users don't need to be activated (we can't enforce it anyways) + usersL %= filter isActivatedOrRemote -- In a team-only conversation we also want to remove bots and guests case (targetRole, Data.convTeam conv) of (TeamAccessRole, Just tid) -> do currentUsers <- use usersL - onlyTeamUsers <- filterM (\user -> lift $ isJust <$> Data.teamMember tid (memId user)) currentUsers + onlyTeamUsers <- flip filterM currentUsers $ \user -> + case memId user of + Mapped _ -> pure False -- remote users can't be team members + Local localId -> lift $ isJust <$> Data.teamMember tid localId assign usersL onlyTeamUsers botsL .= [] _ -> return () @@ -249,7 +256,7 @@ uncheckedUpdateConversationAccess body usr zcon conv (currentAccess, targetAcces case removedUsers of [] -> return () x : xs -> do - e <- Data.removeMembers conv usr (Local <$> list1 x xs) + e <- Data.removeMembers conv usr (list1 x xs) -- push event to all clients, including zconn -- since updateConversationAccess generates a second (member removal) event here for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> push1 p @@ -269,7 +276,7 @@ updateConversationReceiptModeH (usr ::: zcon ::: cnv ::: req ::: _) = do updateConversationReceiptMode :: UserId -> ConnId -> ConvId -> Public.ConversationReceiptModeUpdate -> Galley UpdateResult updateConversationReceiptMode usr zcon cnv receiptModeUpdate@(Public.ConversationReceiptModeUpdate target) = do - (bots, users) <- botsAndUsers <$> Data.members cnv + (bots, users) <- botsAndUsers =<< Data.members cnv ensureActionAllowed ModifyConversationReceiptMode =<< getSelfMember usr users current <- Data.lookupReceiptMode cnv if current == Just target @@ -292,7 +299,7 @@ updateConversationMessageTimerH (usr ::: zcon ::: cnv ::: req) = do updateConversationMessageTimer :: UserId -> ConnId -> ConvId -> Public.ConversationMessageTimerUpdate -> Galley UpdateResult updateConversationMessageTimer usr zcon cnv timerUpdate@(Public.ConversationMessageTimerUpdate target) = do -- checks and balances - (bots, users) <- botsAndUsers <$> Data.members cnv + (bots, users) <- botsAndUsers =<< Data.members cnv ensureActionAllowed ModifyConversationMessageTimer =<< getSelfMember usr users conv <- Data.conversation cnv >>= ifNothing convNotFound ensureGroupConv conv @@ -330,7 +337,7 @@ addCode usr zcon cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound ensureConvMember (Data.convMembers conv) usr ensureAccess conv CodeAccess - let (bots, users) = botsAndUsers $ Data.convMembers conv + (bots, users) <- botsAndUsers $ Data.convMembers conv key <- mkKey cnv mCode <- Data.lookupCode key ReusableCode case mCode of @@ -360,7 +367,7 @@ rmCode usr zcon cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound ensureConvMember (Data.convMembers conv) usr ensureAccess conv CodeAccess - let (bots, users) = botsAndUsers $ Data.convMembers conv + (bots, users) <- botsAndUsers $ Data.convMembers conv key <- mkKey cnv Data.deleteCode key ReusableCode now <- liftIO getCurrentTime @@ -427,12 +434,13 @@ joinConversation zusr zcon cnv access = do ensureAccess conv access zusrMembership <- maybe (pure Nothing) (`Data.teamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] - let newUsers = filter (notIsMember conv . makeIdOpaque) [zusr] - ensureMemberLimit (toList $ Data.convMembers conv) (makeIdOpaque <$> newUsers) + let newUsers = filter (notIsMember conv . Local) [zusr] + ensureMemberLimit (toList $ Data.convMembers conv) (Local <$> newUsers) -- NOTE: When joining conversations, all users become members -- as this is our desired behavior for these types of conversations -- where there is no way to control who joins, etc. - addToConversation (botsAndUsers (Data.convMembers conv)) (zusr, roleNameWireMember) zcon ((,roleNameWireMember) <$> newUsers) conv + mems <- botsAndUsers (Data.convMembers conv) + addToConversation mems (zusr, roleNameWireMember) zcon ((,roleNameWireMember) <$> newUsers) conv addMembersH :: UserId ::: ConnId ::: OpaqueConvId ::: JsonRequest Public.Invite -> Galley Response addMembersH (zusr ::: zcon ::: cid ::: req) = do @@ -453,15 +461,16 @@ addMembers zusr zcon cid invite = do where addMembersToLocalConv convId = do conv <- Data.conversation convId >>= ifNothing convNotFound - let mems = botsAndUsers (Data.convMembers conv) + mems <- botsAndUsers (Data.convMembers conv) self <- getSelfMember zusr (snd mems) ensureActionAllowed AddConversationMember self - toAdd <- fromMemberSize <$> checkedMemberAddSize (toList $ invUsers invite) - let newOpaqueUsers = filter (notIsMember conv) (toList toAdd) - ensureMemberLimit (toList $ Data.convMembers conv) newOpaqueUsers + invitedUsers <- traverse resolveOpaqueUserId (toList $ invUsers invite) + toAdd <- fromMemberSize <$> checkedMemberAddSize invitedUsers + let newUsers = filter (notIsMember conv) (toList toAdd) + ensureMemberLimit (toList $ Data.convMembers conv) newUsers ensureAccess conv InviteAccess ensureConvRoleNotElevated self (invRoleName invite) - (newUsers, newQualifiedUsers) <- partitionMappedOrLocalIds <$> traverse resolveOpaqueUserId newOpaqueUsers + let (newLocalUsers, newQualifiedUsers) = partitionMappedOrLocalIds newUsers -- FUTUREWORK(federation): allow adding remote members -- this one is a bit tricky because all of the checks that need to be done, -- some of them on remote backends. @@ -469,19 +478,19 @@ addMembers zusr zcon cid invite = do throwM . federationNotImplemented case Data.convTeam conv of Nothing -> do - ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) - ensureConnectedOrSameTeam zusr newUsers - Just ti -> teamConvChecks ti newUsers convId conv - addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName invite) <$> newUsers) conv + ensureAccessRole (Data.convAccessRole conv) (zip newLocalUsers $ repeat Nothing) + ensureConnectedOrSameTeam zusr newLocalUsers + Just ti -> teamConvChecks ti newLocalUsers convId conv + addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName invite) <$> newLocalUsers) conv userIsMember u = (^. userId . to (== u)) - teamConvChecks tid newUsers convId conv = do - tms <- Data.teamMembersLimited tid newUsers - let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers + teamConvChecks tid newLocalUsers convId conv = do + tms <- Data.teamMembersLimited tid newLocalUsers + let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newLocalUsers ensureAccessRole (Data.convAccessRole conv) userMembershipMap tcv <- Data.teamConversation tid convId when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged - ensureConnectedOrSameTeam zusr newUsers + ensureConnectedOrSameTeam zusr newLocalUsers updateSelfMemberH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.MemberUpdate -> Galley Response updateSelfMemberH (zusr ::: zcon ::: cid ::: req) = do @@ -495,7 +504,7 @@ updateSelfMember zusr zcon cid update = do m <- getSelfMember zusr (Data.convMembers conv) -- Ensure no self role upgrades for_ (mupConvRoleName update) $ ensureConvRoleNotElevated m - void $ processUpdateMemberEvent zusr zcon cid [m] m update + void $ processUpdateMemberEvent zusr zcon cid [Local <$> m] m update updateOtherMemberH :: UserId ::: ConnId ::: ConvId ::: UserId ::: JsonRequest Public.OtherMemberUpdate -> Galley Response updateOtherMemberH (zusr ::: zcon ::: cid ::: victim ::: req) = do @@ -508,7 +517,7 @@ updateOtherMember zusr zcon cid victim update = do when (zusr == victim) $ throwM invalidTargetUserOp conv <- getConversationAndCheckMembership zusr (Local cid) - let (bots, users) = botsAndUsers (Data.convMembers conv) + (bots, users) <- botsAndUsers (Data.convMembers conv) ensureActionAllowed ModifyOtherConversationMember =<< getSelfMember zusr users memTarget <- getOtherMember victim users e <- processUpdateMemberEvent zusr zcon cid users memTarget (memberUpdate {mupConvRoleName = omuConvRoleName update}) @@ -519,26 +528,26 @@ removeMemberH (zusr ::: zcon ::: cid ::: victim) = do handleUpdateResult <$> removeMember zusr zcon cid victim removeMember :: UserId -> ConnId -> OpaqueConvId -> OpaqueUserId -> Galley UpdateResult -removeMember zusr zcon cid victim = do +removeMember zusr zcon cid opaqueVictim = do resolveOpaqueConvId cid >>= \case Mapped idMapping -> -- FUTUREWORK(federation, #1274): forward request to conversation's backend. throwM . federationNotImplemented $ pure idMapping - Local localConvId -> - removeMemberOfLocalConversation localConvId + Local localConvId -> do + victim <- resolveOpaqueUserId opaqueVictim + removeMemberOfLocalConversation localConvId victim where - removeMemberOfLocalConversation convId = do + removeMemberOfLocalConversation convId victim = do conv <- Data.conversation convId >>= ifNothing convNotFound - let (bots, users) = botsAndUsers (Data.convMembers conv) - genConvChecks conv users + (bots, users) <- botsAndUsers (Data.convMembers conv) + genConvChecks conv users victim case Data.convTeam conv of Nothing -> pure () Just ti -> teamConvChecks convId ti if victim `isMember` users then do - resolvedVictim <- resolveOpaqueUserId victim - event <- Data.removeMembers conv zusr (singleton resolvedVictim) - case resolvedVictim of + event <- Data.removeMembers conv zusr (singleton victim) + case victim of Local _ -> pure () -- nothing to do Mapped _ -> do -- FUTUREWORK(federation, #1274): users can be on other backend, how to notify it? @@ -548,9 +557,9 @@ removeMember zusr zcon cid victim = do void . forkIO $ void $ External.deliver (bots `zip` repeat event) pure $ Updated event else pure Unchanged - genConvChecks conv usrs = do + genConvChecks conv usrs victim = do ensureGroupConv conv - if makeIdOpaque zusr == victim + if Local zusr == victim then ensureActionAllowed LeaveConversation =<< getSelfMember zusr usrs else ensureActionAllowed RemoveConversationMember =<< getSelfMember zusr usrs teamConvChecks convId tid = do @@ -658,7 +667,7 @@ newMessage :: Maybe ConvId -> NewOtrMessage -> UTCTime -> - (Member, ClientId, Text) -> + (LocalMember, ClientId, Text) -> ([(BotMember, Event)], [Maybe Push]) -> ([(BotMember, Event)], [Maybe Push]) newMessage usr con cnv msg now (m, c, t) ~(toBots, toUsers) = @@ -669,9 +678,11 @@ newMessage usr con cnv msg now (m, c, t) ~(toBots, toUsers) = otrCiphertext = t, otrData = newOtrData msg } - conv = fromMaybe (selfConv $ memId m) cnv -- use recipient's client's self conversation on broadcast + -- use recipient's client's self conversation on broadcast + -- (with federation, this might not work for remote members) + conv = fromMaybe (selfConv $ memId m) cnv e = Event OtrMessageAdd conv usr now (Just $ EdOtrMessage o) - r = recipient m & recipientClients .~ (RecipientClientsSome $ singleton c) + r = recipient (Local <$> m) & recipientClients .~ (RecipientClientsSome $ singleton c) in case newBotMember m of Just b -> ((b, e) : toBots, toUsers) Nothing -> @@ -699,7 +710,7 @@ updateConversationName zusr zcon cnv convRename = do unless alive $ do Data.deleteConversation cnv throwM convNotFound - (bots, users) <- botsAndUsers <$> Data.members cnv + (bots, users) <- botsAndUsers =<< Data.members cnv ensureActionAllowed ModifyConversationName =<< getSelfMember zusr users now <- liftIO getCurrentTime cn <- rangeChecked (cupName convRename) @@ -719,7 +730,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do isTyping :: UserId -> ConnId -> ConvId -> Public.TypingData -> Galley () isTyping zusr zcon cnv typingData = do mm <- Data.members cnv - unless (makeIdOpaque zusr `isMember` mm) $ + unless (Local zusr `isMember` mm) $ throwM convNotFound now <- liftIO getCurrentTime let e = Event Typing cnv zusr now (Just $ EdTyping typingData) @@ -760,13 +771,13 @@ addBot zusr zcon b = do pure e where regularConvChecks c = do - let (bots, users) = botsAndUsers (Data.convMembers c) - unless (makeIdOpaque zusr `isMember` users) $ + (bots, users) <- botsAndUsers (Data.convMembers c) + unless (Local zusr `isMember` users) $ throwM convNotFound ensureGroupConv c ensureActionAllowed AddConversationMember =<< getSelfMember zusr users unless (any ((== b ^. addBotId) . botMemId) bots) $ - ensureMemberLimit (toList $ Data.convMembers c) [makeIdOpaque (botUserId (b ^. addBotId))] + ensureMemberLimit (toList $ Data.convMembers c) [Local (botUserId (b ^. addBotId))] return (bots, users) teamConvChecks cid tid = do tcv <- Data.teamConversation tid cid @@ -781,9 +792,9 @@ rmBotH (zusr ::: zcon ::: req) = do rmBot :: UserId -> Maybe ConnId -> RemoveBot -> Galley UpdateResult rmBot zusr zcon b = do c <- Data.conversation (b ^. rmBotConv) >>= ifNothing convNotFound - unless (makeIdOpaque zusr `isMember` Data.convMembers c) $ + unless (Local zusr `isMember` Data.convMembers c) $ throwM convNotFound - let (bots, users) = botsAndUsers (Data.convMembers c) + (bots, users) <- botsAndUsers (Data.convMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) then pure Unchanged else do @@ -792,7 +803,7 @@ rmBot zusr zcon b = do let e = Event MemberLeave (Data.convId c) zusr t evd for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn .~ zcon - Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) + Data.removeMember (Local (botUserId (b ^. rmBotId))) (Data.convId c) Data.eraseClients (botUserId (b ^. rmBotId)) void . forkIO $ void $ External.deliver (bots `zip` repeat e) pure $ Updated e @@ -820,19 +831,19 @@ ensureGroupConv c = case Data.convType c of ConnectConv -> throwM invalidConnectOp _ -> return () -ensureMemberLimit :: [Member] -> [OpaqueUserId] -> Galley () +ensureMemberLimit :: [Member] -> [MappedOrLocalId Id.U] -> Galley () ensureMemberLimit old new = do o <- view options let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) when (length old + length new > maxSize) $ throwM tooManyMembers -notIsMember :: Data.Conversation -> OpaqueUserId -> Bool +notIsMember :: Data.Conversation -> MappedOrLocalId Id.U -> Bool notIsMember cc u = not $ isMember u (Data.convMembers cc) ensureConvMember :: [Member] -> UserId -> Galley () ensureConvMember users usr = - unless (makeIdOpaque usr `isMember` users) $ + unless (Local usr `isMember` users) $ throwM convNotFound ensureAccess :: Data.Conversation -> Access -> Galley () @@ -840,32 +851,20 @@ ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ throwM convAccessDenied -applyMemUpdateChanges :: Member -> MemberUpdateData -> Member -applyMemUpdateChanges m u = - m - { memOtrMuted = fromMaybe (memOtrMuted m) (misOtrMuted u), - memOtrMutedRef = misOtrMutedRef u <|> memOtrMutedRef m, - memOtrArchived = fromMaybe (memOtrArchived m) (misOtrArchived u), - memOtrArchivedRef = misOtrArchivedRef u <|> memOtrArchivedRef m, - memHidden = fromMaybe (memHidden m) (misHidden u), - memHiddenRef = misHiddenRef u <|> memHiddenRef m, - memConvRoleName = fromMaybe (memConvRoleName m) (misConvRoleName u) - } - processUpdateMemberEvent :: UserId -> ConnId -> ConvId -> [Member] -> - Member -> + LocalMember -> MemberUpdate -> Galley Event processUpdateMemberEvent zusr zcon cid users target update = do up <- Data.updateMember cid (memId target) update now <- liftIO getCurrentTime let e = Event MemberStateUpdate cid zusr now (Just $ EdMemberUpdate up) - let ms = applyMemUpdateChanges target up - for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient ms : fmap recipient (delete target users))) $ \p -> + let recipients = fmap recipient ((Local <$> target) : filter ((/= Local (memId target)) . memId) users) + for_ (newPush ListComplete (evtFrom e) (ConvEvent e) recipients) $ \p -> push1 $ p & pushConn ?~ zcon @@ -878,7 +877,7 @@ processUpdateMemberEvent zusr zcon cid users target update = do data CheckedOtrRecipients = -- | Valid sender (user and client) and no missing recipients, -- or missing recipients have been willfully ignored. - ValidOtrRecipients !ClientMismatch [(Member, ClientId, Text)] + ValidOtrRecipients !ClientMismatch [(LocalMember, ClientId, Text)] | -- | Missing recipients. MissingOtrRecipients !ClientMismatch | -- | Invalid sender (user). @@ -892,7 +891,7 @@ withValidOtrBroadcastRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(Member, ClientId, Text)] -> Galley ()) -> + ([(LocalMember, ClientId, Text)] -> Galley ()) -> Galley OtrResult withValidOtrBroadcastRecipients usr clt rcps val now go = Teams.withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit @@ -938,21 +937,26 @@ withValidOtrRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(Member, ClientId, Text)] -> Galley ()) -> + ([(LocalMember, ClientId, Text)] -> Galley ()) -> Galley OtrResult withValidOtrRecipients usr clt cnv rcps val now go = do alive <- Data.isConvAlive cnv unless alive $ do Data.deleteConversation cnv throwM convNotFound + -- FUTUREWORK(federation): also handle remote members membs <- Data.members cnv - let memIds = (memId <$> membs) + let localMembers = flip mapMaybe membs $ \memb -> + case memId memb of + Local localId -> Just (memb {memId = localId} :: LocalMember) + Mapped _ -> Nothing + let localMemberIds = memId <$> localMembers isInternal <- view $ options . optSettings . setIntraListing clts <- if isInternal - then Clients.fromUserClients <$> Intra.lookupClients memIds - else Data.lookupClients memIds - handleOtrResponse usr clt rcps membs clts val now go + then Clients.fromUserClients <$> Intra.lookupClients localMemberIds + else Data.lookupClients localMemberIds + handleOtrResponse usr clt rcps localMembers clts val now go handleOtrResponse :: -- | Proposed sender (user) @@ -962,7 +966,7 @@ handleOtrResponse :: -- | Proposed recipients (users & clients). OtrRecipients -> -- | Members to consider as valid recipients. - [Member] -> + [LocalMember] -> -- | Clients to consider as valid recipients. Clients -> -- | How to filter missing clients. @@ -970,7 +974,7 @@ handleOtrResponse :: -- | The current timestamp. UTCTime -> -- | Callback if OtrRecipients are valid - ([(Member, ClientId, Text)] -> Galley ()) -> + ([(LocalMember, ClientId, Text)] -> Galley ()) -> Galley OtrResult handleOtrResponse usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of ValidOtrRecipients m r -> go r >> pure (OtrSent m) @@ -990,7 +994,7 @@ checkOtrRecipients :: -- | Proposed recipients (users & clients). OtrRecipients -> -- | Members to consider as valid recipients. - [Member] -> + [LocalMember] -> -- | Clients to consider as valid recipients. Clients -> -- | How to filter missing clients. @@ -1008,7 +1012,7 @@ checkOtrRecipients (makeIdOpaque -> usr) sid prs vms vcs val now next u c t rs | Just m <- member u c = (m, c, t) : rs | otherwise = rs - member :: OpaqueUserId -> ClientId -> Maybe Member + member :: OpaqueUserId -> ClientId -> Maybe LocalMember member u c | Just m <- Map.lookup u vmembers, Clients.contains u c vclients = diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 84a9d7497d8..80610ad44a6 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -46,6 +46,7 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) import Network.Wai.Utilities +import qualified System.Logger.Class as Log import UnliftIO (concurrently) type JSON = Media "application" "json" @@ -111,7 +112,7 @@ ensureReAuthorised u secret = do -- is permitted. -- If not, throw 'Member'; if the user is found and does not have the given permission, throw -- 'operationDenied'. Otherwise, return the found user. -ensureActionAllowed :: Action -> Member -> Galley () +ensureActionAllowed :: Action -> InternalMember a -> Galley () ensureActionAllowed action mem = case isActionAllowed action (memConvRoleName mem) of Just True -> return () Just False -> throwM (actionDenied action) @@ -124,7 +125,7 @@ ensureActionAllowed action mem = case isActionAllowed action (memConvRoleName me -- own. This is used to ensure users cannot "elevate" allowed actions -- This function needs to be review when custom roles are introduced since only -- custom roles can cause `roleNameToActions` to return a Nothing -ensureConvRoleNotElevated :: Member -> RoleName -> Galley () +ensureConvRoleNotElevated :: InternalMember a -> RoleName -> Galley () ensureConvRoleNotElevated origMember targetRole = do case (roleNameToActions targetRole, roleNameToActions (memConvRoleName origMember)) of (Just targetActions, Just memberActions) -> @@ -163,21 +164,21 @@ permissionCheckTeamConv zusr cnv perm = Data.conversation cnv >>= \case acceptOne2One :: UserId -> Data.Conversation -> Maybe ConnId -> Galley Data.Conversation acceptOne2One usr conv conn = case Data.convType conv of One2OneConv -> - if makeIdOpaque usr `isMember` mems + if Local usr `isMember` mems then return conv else do now <- liftIO getCurrentTime mm <- snd <$> Data.addMember now cid usr return $ conv {Data.convMembers = mems <> toList mm} ConnectConv -> case mems of - [_, _] | makeIdOpaque usr `isMember` mems -> promote + [_, _] | Local usr `isMember` mems -> promote [_, _] -> throwM convNotFound _ -> do when (length mems > 2) $ throwM badConvState now <- liftIO getCurrentTime (e, mm) <- Data.addMember now cid usr - conv' <- if isJust (find ((usr /=) . memId) mems) then promote else pure conv + conv' <- if isJust (find ((Local usr /=) . memId) mems) then promote else pure conv let mems' = mems <> toList mm for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> mems')) $ \p -> push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect @@ -194,53 +195,69 @@ acceptOne2One usr conv conn = case Data.convType conv of "Connect conversation with more than 2 members: " <> LT.pack (show cid) -isBot :: Member -> Bool +isBot :: InternalMember a -> Bool isBot = isJust . memService -isMember :: Foldable m => OpaqueUserId -> m Member -> Bool -isMember u = isJust . find ((u ==) . makeIdOpaque . memId) +isMember :: (Eq a, Foldable m) => a -> m (InternalMember a) -> Bool +isMember u = isJust . find ((u ==) . memId) -findMember :: Data.Conversation -> UserId -> Maybe Member +findMember :: Data.Conversation -> MappedOrLocalId Id.U -> Maybe Member findMember c u = find ((u ==) . memId) (Data.convMembers c) -botsAndUsers :: Foldable t => t Member -> ([BotMember], [Member]) -botsAndUsers = foldr fn ([], []) +botsAndUsers :: (Log.MonadLogger m, Traversable t) => t Member -> m ([BotMember], [Member]) +botsAndUsers = fmap fold . traverse botOrUser where - fn m ~(bb, mm) = case newBotMember m of - Nothing -> (bb, m : mm) - Just b -> (b : bb, mm) + botOrUser m = case memService m of + Just _ -> do + -- we drop invalid bots here, which shouldn't happen + bot <- mkBotMember m + pure (toList bot, []) + Nothing -> + pure ([], [m]) + mkBotMember :: Log.MonadLogger m => Member -> m (Maybe BotMember) + mkBotMember m = case memId m of + Mapped _ -> do + Log.warn $ Log.msg @Text "Bot member with qualified user ID found, ignoring it." + pure Nothing -- remote members can't be bots for now + Local localMemId -> + pure $ newBotMember (m {memId = localMemId} :: LocalMember) location :: ToByteString a => a -> Response -> Response location = addHeader hLocation . toByteString' nonTeamMembers :: [Member] -> [TeamMember] -> [Member] -nonTeamMembers cm tm = filter (not . flip isTeamMember tm . memId) cm +nonTeamMembers cm tm = filter (not . isMemberOfTeam . memId) cm + where + isMemberOfTeam = \case + Local uid -> isTeamMember uid tm + Mapped _ -> False -- teams and their members are always on the same backend convMembsAndTeamMembs :: [Member] -> [TeamMember] -> [Recipient] convMembsAndTeamMembs convMembs teamMembs = - fmap userRecipient . setnub $ map memId convMembs <> map (view userId) teamMembs + fmap userRecipient . setnub $ map memId convMembs <> map (Local . view userId) teamMembs where setnub = Set.toList . Set.fromList membersToRecipients :: Maybe UserId -> [TeamMember] -> [Recipient] -membersToRecipients Nothing = map (userRecipient . view userId) -membersToRecipients (Just u) = map userRecipient . filter (/= u) . map (view userId) +membersToRecipients Nothing = map (userRecipient . Local . view userId) +membersToRecipients (Just u) = map (userRecipient . Local) . filter (/= u) . map (view userId) --- Note that we use 2 nearly identical functions but slightly different +-- | Note that we use 2 nearly identical functions but slightly different -- semantics; when using `getSelfMember`, if that user is _not_ part of -- the conversation, we don't want to disclose that such a conversation -- with that id exists. -getSelfMember :: Foldable t => UserId -> t Member -> Galley Member +getSelfMember :: Foldable t => UserId -> t Member -> Galley LocalMember getSelfMember = getMember convNotFound -getOtherMember :: Foldable t => UserId -> t Member -> Galley Member +getOtherMember :: Foldable t => UserId -> t Member -> Galley LocalMember getOtherMember = getMember convMemberNotFound -getMember :: Foldable t => Error -> UserId -> t Member -> Galley Member +-- | Since we search by local user ID, we know that the member must be local. +getMember :: Foldable t => Error -> UserId -> t Member -> Galley LocalMember getMember ex u ms = do - let member = find ((u ==) . memId) ms + let member = find ((Local u ==) . memId) ms case member of - Just m -> return m + Just m -> return (m {memId = u}) Nothing -> throwM ex getConversationAndCheckMembership :: UserId -> MappedOrLocalId Id.C -> Galley Data.Conversation @@ -256,7 +273,7 @@ getConversationAndCheckMembershipWithError ex zusr = \case when (DataTypes.isConvDeleted c) $ do Data.deleteConversation convId throwM convNotFound - unless (makeIdOpaque zusr `isMember` Data.convMembers c) $ + unless (Local zusr `isMember` Data.convMembers c) $ throwM ex return c diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 05417141416..492a273b11e 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -20,6 +20,7 @@ module Galley.Data ( ResultSet, ResultSetType (..), + mkResultSet, resultSetType, resultSetResult, schemaVersion, @@ -57,7 +58,8 @@ module Galley.Data acceptConnect, conversation, conversationIdsFrom, - conversationIdsForPagination, + conversationIdRowsFrom, + conversationIdRowsForPagination, conversationIdsOf, conversationMeta, conversations, @@ -95,6 +97,8 @@ module Galley.Data -- * Utilities one2OneConvId, newMember, + MappedOrLocalIdRow, + toMappedOrLocalId, -- * Defaults defRole, @@ -107,12 +111,14 @@ import Cassandra import Cassandra.Util import Control.Arrow (second) import Control.Lens hiding ((<|)) -import Control.Monad.Catch (MonadThrow) +import Control.Monad.Catch (MonadThrow, throwM) import Data.Bifunctor (first) import Data.ByteString.Conversion hiding (parser) +import Data.Coerce (coerce) +import Data.Domain (Domain) import Data.Function (on) import Data.Id as Id -import Data.IdMapping +import Data.IdMapping (IdMapping (IdMapping), MappedOrLocalId (Local, Mapped), opaqueIdFromMappedOrLocal) import Data.Json.Util (UTCTimeMillis (..)) import Data.LegalHold (UserLegalHoldStatus (..)) import qualified Data.List.Extra as List @@ -120,11 +126,14 @@ import Data.List.Split (chunksOf) import Data.List1 (List1, list1, singleton) import qualified Data.Map.Strict as Map import Data.Misc (Milliseconds) +import Data.Qualified (Qualified (Qualified)) import Data.Range import qualified Data.Set as Set +import qualified Data.String.Conversions as Str.C (cs) import Data.Time.Clock import qualified Data.UUID.Tagged as U import Data.UUID.V4 (nextRandom) +import Galley.API.Error (internalErrorWithDescription) import Galley.App import Galley.Data.Instances () import qualified Galley.Data.Queries as Cql @@ -140,7 +149,6 @@ import Galley.Validation import Imports hiding (Set, max) import System.Logger.Class (MonadLogger) import qualified System.Logger.Class as Log -import System.Logger.Message ((+++), msg, val) import UnliftIO (async, mapConcurrently, wait) -- We use this newtype to highlight the fact that the 'Page' wrapped in here @@ -154,25 +162,27 @@ import UnliftIO (async, mapConcurrently, wait) -- Thus, and since we don't want to expose the ResultSet constructor -- because it gives access to `nextPage`, we give accessors to the results -- and a more typed `hasMore` (ResultSetComplete | ResultSetTruncated) -newtype ResultSet a = ResultSet {page :: Page a} +data ResultSet a = ResultSet + { resultSetResult :: [a], + resultSetType :: ResultSetType + } + deriving stock (Show, Functor, Foldable, Traversable) --- A more descriptive type than using a simple bool to represent `hasMore` +-- | A more descriptive type than using a simple bool to represent `hasMore` data ResultSetType = ResultSetComplete | ResultSetTruncated - deriving (Eq) + deriving stock (Eq, Show) -resultSetType :: ResultSet a -> ResultSetType -resultSetType rs = - if hasMore (page rs) - then ResultSetTruncated - else ResultSetComplete - -resultSetResult :: ResultSet a -> [a] -resultSetResult = result . page +mkResultSet :: Page a -> ResultSet a +mkResultSet page = ResultSet (result page) typ + where + typ + | hasMore page = ResultSetTruncated + | otherwise = ResultSetComplete schemaVersion :: Int32 -schemaVersion = 43 +schemaVersion = 44 -- | Insert a conversation code insertCode :: MonadClient m => Code -> m () @@ -214,7 +224,7 @@ teamIdsOf usr (fromList . fromRange -> tids) = teamIdsFrom :: MonadClient m => UserId -> Maybe TeamId -> Range 1 100 Int32 -> m (ResultSet TeamId) teamIdsFrom usr range (fromRange -> max) = - ResultSet . fmap runIdentity . strip <$> case range of + mkResultSet . fmap runIdentity . strip <$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) (max + 1)) where @@ -336,7 +346,7 @@ createTeam t uid (fromRange -> n) (fromRange -> i) k b = do initialStatus Binding = PendingActive -- Team becomes Active after User account activation initialStatus NonBinding = Active -deleteTeam :: MonadClient m => TeamId -> m () +deleteTeam :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> m () deleteTeam tid = do retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) @@ -413,7 +423,7 @@ listBillingTeamMembers tid = fmap runIdentity <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) -removeTeamConv :: MonadClient m => TeamId -> ConvId -> m () +removeTeamConv :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> ConvId -> m () removeTeamConv tid cid = do retry x5 $ batch $ do setType BatchLogged @@ -448,7 +458,7 @@ isConvAlive cid = do Just (Just False) -> pure True conversation :: - (MonadUnliftIO m, MonadClient m) => + (MonadUnliftIO m, MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m (Maybe Conversation) conversation conv = do @@ -458,7 +468,10 @@ conversation conv = do {- "Garbage collect" the conversation, i.e. the conversation may be marked as deleted, in which case we delete it and return Nothing -} -conversationGC :: MonadClient m => (Maybe Conversation) -> m (Maybe Conversation) +conversationGC :: + (MonadClient m, Log.MonadLogger m, MonadThrow m) => + (Maybe Conversation) -> + m (Maybe Conversation) conversationGC conv = case join (convDeleted <$> conv) of (Just True) -> do sequence_ $ deleteConversation . convId <$> conv @@ -482,7 +495,7 @@ conversations ids = do return $ map (`Map.lookup` m) ids flatten (i, c) cc = case c of Nothing -> do - Log.warn $ msg (val "No conversation for: " +++ toByteString i) + Log.warn $ Log.msg ("No conversation for: " <> toByteString i) return cc Just c' -> return (c' : cc) @@ -503,23 +516,43 @@ conversationMeta conv = where toConvMeta (t, c, a, r, n, i, _, mt, rm) = ConversationMeta conv t c (defAccess t a) (maybeRole t r) n i mt rm -conversationIdsFrom :: MonadClient m => UserId -> Maybe OpaqueConvId -> Range 1 1000 Int32 -> m (ResultSet OpaqueConvId) -conversationIdsFrom usr start (fromRange -> max) = - ResultSet . fmap runIdentity . strip <$> case start of +conversationIdsFrom :: + (MonadClient m, Log.MonadLogger m, MonadThrow m) => + UserId -> + Maybe OpaqueConvId -> + Range 1 1000 Int32 -> + m (ResultSet (MappedOrLocalId Id.C)) +conversationIdsFrom usr start max = + traverse toMappedOrLocalId =<< conversationIdRowsFrom usr start max + +conversationIdRowsFrom :: + (MonadClient m) => + UserId -> + Maybe OpaqueConvId -> + Range 1 1000 Int32 -> + m (ResultSet (MappedOrLocalIdRow Id.C)) +conversationIdRowsFrom usr start (fromRange -> max) = + mkResultSet . strip <$> case start of Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) (max + 1)) where strip p = p {result = take (fromIntegral max) (result p)} -conversationIdsForPagination :: MonadClient m => UserId -> Maybe OpaqueConvId -> Range 1 1000 Int32 -> m (Page OpaqueConvId) -conversationIdsForPagination usr start (fromRange -> max) = - fmap runIdentity <$> case start of +-- | We can't easily apply toMappedOrLocalId here, so we leave it to the consumers of this function. +conversationIdRowsForPagination :: MonadClient m => UserId -> Maybe OpaqueConvId -> Range 1 1000 Int32 -> m (Page (MappedOrLocalIdRow Id.C)) +conversationIdRowsForPagination usr start (fromRange -> max) = + case start of Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) max) Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) max) -conversationIdsOf :: MonadClient m => UserId -> Range 1 32 (List OpaqueConvId) -> m [OpaqueConvId] +conversationIdsOf :: + (MonadClient m, Log.MonadLogger m, MonadThrow m) => + UserId -> + Range 1 32 (List OpaqueConvId) -> + m [MappedOrLocalId Id.C] conversationIdsOf usr (fromList . fromRange -> cids) = - map runIdentity <$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) + traverse toMappedOrLocalId + =<< retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) createConversation :: MonadClient m => @@ -613,7 +646,7 @@ lookupReceiptMode cid = join . fmap runIdentity <$> retry x1 (query1 Cql.selectR updateConversationMessageTimer :: MonadClient m => ConvId -> Maybe Milliseconds -> m () updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) -deleteConversation :: MonadClient m => ConvId -> m () +deleteConversation :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m () deleteConversation cid = do retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) mm <- members cid @@ -687,36 +720,80 @@ privateRole = PrivateAccessRole privateOnly :: Set Access privateOnly = Set [PrivateAccess] +type MappedOrLocalIdRow a = (Id (Opaque a), Maybe (Id (Remote a)), Maybe Domain) + +toMappedOrLocalId :: (Log.MonadLogger m, MonadThrow m) => MappedOrLocalIdRow a -> m (MappedOrLocalId a) +toMappedOrLocalId = \case + (mappedId, Just remoteId, Just domain) -> + pure $ Mapped (IdMapping (coerce mappedId) (Qualified remoteId domain)) + (localId, Nothing, Nothing) -> + pure $ Local (coerce localId) + invalid -> do + -- This should never happen as we always write rows with either both or none of these + -- values. + -- FUTUREWORK: we could try to recover from this situation by checking if an ID mapping + -- for this mapped ID exists (and potentially even repair the row). At the moment, the + -- problem seems unlikely enough not to warrant the complexity, though. + -- In some cases it could also be better not to fail, but skip this entry, e.g. when + -- deleting a user, we should remove him from all conversations we can, not stop halfway. + let msg = "Invalid remote ID in database row: " <> show invalid + Log.err $ Log.msg msg + throwM $ internalErrorWithDescription (Str.C.cs msg) + +fromMappedOrLocalId :: MappedOrLocalId a -> MappedOrLocalIdRow a +fromMappedOrLocalId = \case + Local localId -> + (makeIdOpaque localId, Nothing, Nothing) + Mapped (IdMapping mappedId (Qualified remoteId domain)) -> + (makeMappedIdOpaque mappedId, Just remoteId, Just domain) + -- Conversation Members ----------------------------------------------------- -member :: MonadClient m => ConvId -> UserId -> m (Maybe Member) -member cnv usr = (toMember =<<) <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) +member :: + (MonadClient m, Log.MonadLogger m, MonadThrow m) => + ConvId -> + UserId -> + m (Maybe Member) +member cnv usr = + fmap (join @Maybe) . traverse toMember + =<< retry x1 (query1 Cql.selectMember (params Quorum (cnv, makeIdOpaque usr))) -memberLists :: MonadClient m => [ConvId] -> m [[Member]] +memberLists :: + (MonadClient m, Log.MonadLogger m, MonadThrow m) => + [ConvId] -> + m [[Member]] memberLists convs = do mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) - let m = foldr (insert . mkMem) Map.empty mems - return $ map (\i -> fromMaybe [] (Map.lookup i m)) convs + convMembers <- foldrM (\m acc -> liftA2 insert (mkMem m) (pure acc)) Map.empty mems + return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs where insert Nothing acc = acc insert (Just (conv, mem)) acc = let f = (Just . maybe [mem] (mem :)) in Map.alter f conv acc - mkMem (cnv, usr, srv, prv, st, omu, omus, omur, oar, oarr, hid, hidr, crn) = - (cnv,) <$> toMember (usr, srv, prv, st, omu, omus, omur, oar, oarr, hid, hidr, crn) + mkMem (cnv, usr, usrRemoteId, usrRemoteDomain, srv, prv, st, omu, omus, omur, oar, oarr, hid, hidr, crn) = + fmap (cnv,) <$> toMember (usr, usrRemoteId, usrRemoteDomain, srv, prv, st, omu, omus, omur, oar, oarr, hid, hidr, crn) -members :: MonadClient m => ConvId -> m [Member] +members :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m [Member] members conv = join <$> memberLists [conv] +-- | Add a member to a local conversation, as an admin. addMember :: MonadClient m => UTCTime -> ConvId -> UserId -> m (Event, List1 Member) addMember t c u = addMembersUnchecked t c u (singleton u) +-- | Add members to a local conversation. addMembersWithRole :: MonadClient m => UTCTime -> ConvId -> (UserId, RoleName) -> ConvMemberAddSizeChecked (List1 (UserId, RoleName)) -> m (Event, List1 Member) addMembersWithRole t c orig mems = addMembersUncheckedWithRole t c orig (fromMemberSize mems) +-- | Add members to a local conversation, all as admins. +-- Please make sure the conversation doesn't exceed the maximum size! addMembersUnchecked :: MonadClient m => UTCTime -> ConvId -> UserId -> List1 UserId -> m (Event, List1 Member) addMembersUnchecked t conv orig usrs = addMembersUncheckedWithRole t conv (orig, roleNameWireAdmin) ((,roleNameWireAdmin) <$> usrs) +-- | Add members to a local conversation. +-- Please make sure the conversation doesn't exceed the maximum size! +-- +-- For now, we only accept local 'UserId's, but that will change with federation. addMembersUncheckedWithRole :: MonadClient m => UTCTime -> ConvId -> (UserId, RoleName) -> List1 (UserId, RoleName) -> m (Event, List1 Member) addMembersUncheckedWithRole t conv (orig, _origRole) usrs = do -- batch statement with 500 users are known to be above the batch size limit @@ -732,10 +809,17 @@ addMembersUncheckedWithRole t conv (orig, _origRole) usrs = do setType BatchLogged setConsistency Quorum for_ chunk $ \(u, r) -> do - addPrepQuery Cql.insertUserConv (u, conv) - addPrepQuery Cql.insertMember (conv, u, Nothing, Nothing, r) + -- Conversation is local, so we can add any member to it (including remote ones). + let (usrOpaqueId, usrRemoteId, usrRemoteDomain) = fromMappedOrLocalId (Local u) + addPrepQuery Cql.insertMember (conv, usrOpaqueId, usrRemoteId, usrRemoteDomain, Nothing, Nothing, r) + -- Once we accept remote users in this function, we need to distinguish here between + -- local and remote ones. + -- - For local members, we add the conversation to the table as it's done already. + -- - For remote members, we don't do anything here and assume an additional call to + -- their backend has been (or will be) made separately. + addPrepQuery Cql.insertUserConv (u, makeIdOpaque conv, Nothing, Nothing) let e = Event MemberJoin conv orig t (Just . EdMembersJoin . SimpleMembers . toSimpleMembers $ toList usrs) - return (e, fmap (uncurry newMemberWithRole) usrs) + return (e, fmap (uncurry newMemberWithRole . first Local) usrs) where toSimpleMembers :: [(UserId, RoleName)] -> [SimpleMember] toSimpleMembers = fmap (uncurry SimpleMember) @@ -745,16 +829,17 @@ updateMember cid uid mup = do retry x5 $ batch $ do setType BatchUnLogged setConsistency Quorum + let opaqueUserId = makeIdOpaque uid for_ (mupOtrMute mup) $ \m -> - addPrepQuery Cql.updateOtrMemberMuted (m, mupOtrMuteRef mup, cid, uid) + addPrepQuery Cql.updateOtrMemberMuted (m, mupOtrMuteRef mup, cid, opaqueUserId) for_ (mupOtrMuteStatus mup) $ \ms -> - addPrepQuery Cql.updateOtrMemberMutedStatus (ms, mupOtrMuteRef mup, cid, uid) + addPrepQuery Cql.updateOtrMemberMutedStatus (ms, mupOtrMuteRef mup, cid, opaqueUserId) for_ (mupOtrArchive mup) $ \a -> - addPrepQuery Cql.updateOtrMemberArchived (a, mupOtrArchiveRef mup, cid, uid) + addPrepQuery Cql.updateOtrMemberArchived (a, mupOtrArchiveRef mup, cid, opaqueUserId) for_ (mupHidden mup) $ \h -> - addPrepQuery Cql.updateMemberHidden (h, mupHiddenRef mup, cid, uid) + addPrepQuery Cql.updateMemberHidden (h, mupHiddenRef mup, cid, opaqueUserId) for_ (mupConvRoleName mup) $ \r -> - addPrepQuery Cql.updateMemberConvRoleName (r, cid, uid) + addPrepQuery Cql.updateMemberConvRoleName (r, cid, opaqueUserId) return MemberUpdateData { misTarget = Just uid, @@ -777,8 +862,8 @@ removeMembers conv orig victims = do for_ (toList victims) $ \u -> do addPrepQuery Cql.removeMember (convId conv, opaqueIdFromMappedOrLocal u) case u of - Local localId -> - addPrepQuery Cql.deleteUserConv (localId, convId conv) + Local userLocalId -> + addPrepQuery Cql.deleteUserConv (userLocalId, makeIdOpaque (convId conv)) Mapped _ -> -- the user's conversation has to be deleted on their own backend pure () @@ -790,17 +875,22 @@ removeMembers conv orig victims = do Local localId -> Just localId Mapped _ -> Nothing -removeMember :: MonadClient m => UserId -> ConvId -> m () +removeMember :: MonadClient m => MappedOrLocalId Id.U -> ConvId -> m () removeMember usr cnv = retry x5 $ batch $ do setType BatchLogged setConsistency Quorum - addPrepQuery Cql.removeMember (cnv, makeIdOpaque usr) - addPrepQuery Cql.deleteUserConv (usr, cnv) - -newMember :: UserId -> Member + addPrepQuery Cql.removeMember (cnv, opaqueIdFromMappedOrLocal usr) + case usr of + Local userLocalId -> + addPrepQuery Cql.deleteUserConv (userLocalId, makeIdOpaque cnv) + Mapped _ -> + -- the user's conversation has to be deleted on their own backend + pure () + +newMember :: a -> InternalMember a newMember = flip newMemberWithRole roleNameWireAdmin -newMemberWithRole :: UserId -> RoleName -> Member +newMemberWithRole :: a -> RoleName -> InternalMember a newMemberWithRole u r = Member { memId = u, @@ -816,37 +906,45 @@ newMemberWithRole u r = } toMember :: - ( UserId, + (Log.MonadLogger m, MonadThrow m) => + ( OpaqueUserId, + Maybe RemoteUserId, + Maybe Domain, Maybe ServiceId, Maybe ProviderId, Maybe Cql.MemberStatus, + -- otr muted Maybe Bool, Maybe MutedStatus, - Maybe Text, -- otr muted + Maybe Text, + -- otr archived Maybe Bool, - Maybe Text, -- otr archived + Maybe Text, + -- hidden Maybe Bool, - Maybe Text, -- hidden - Maybe RoleName -- conversation role name + Maybe Text, + -- conversation role name + Maybe RoleName ) -> - Maybe Member -toMember (usr, srv, prv, sta, omu, omus, omur, oar, oarr, hid, hidr, crn) = - if sta /= Just 0 - then Nothing - else - Just $ - Member - { memId = usr, - memService = newServiceRef <$> srv <*> prv, - memOtrMuted = fromMaybe False omu, - memOtrMutedStatus = omus, - memOtrMutedRef = omur, - memOtrArchived = fromMaybe False oar, - memOtrArchivedRef = oarr, - memHidden = fromMaybe False hid, - memHiddenRef = hidr, - memConvRoleName = fromMaybe roleNameWireAdmin crn - } + m (Maybe Member) +toMember (usr, usrRemoteId, usrRemoteDomain, srv, prv, sta, omu, omus, omur, oar, oarr, hid, hidr, crn) = + toMappedOrLocalId (usr, usrRemoteId, usrRemoteDomain) <&> \memberId -> + if sta /= Just 0 + then Nothing + else + Just $ + Member + { memId = memberId, + memService = newServiceRef <$> srv <*> prv, + memOtrMuted = fromMaybe False omu, + memOtrMutedStatus = omus, + memOtrMutedRef = omur, + memOtrArchived = fromMaybe False oar, + memOtrArchivedRef = oarr, + memHidden = fromMaybe False hid, + memHiddenRef = hidr, + memConvRoleName = fromMaybe roleNameWireAdmin crn + } -- Clients ------------------------------------------------------------------ diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index 35193844c2a..2ba61f16435 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -237,51 +237,50 @@ deleteCode = "DELETE FROM conversation_codes WHERE key = ? AND scope = ?" -- User Conversations ------------------------------------------------------- -selectUserConvs :: PrepQuery R (Identity UserId) (Identity OpaqueConvId) -selectUserConvs = "select conv from user where user = ? order by conv" +selectUserConvs :: PrepQuery R (Identity UserId) (OpaqueConvId, Maybe RemoteConvId, Maybe Domain) +selectUserConvs = "select conv, conv_remote_id, conv_remote_domain from user where user = ? order by conv" -selectUserConvsIn :: PrepQuery R (UserId, [OpaqueConvId]) (Identity OpaqueConvId) -selectUserConvsIn = "select conv from user where user = ? and conv in ? order by conv" +selectUserConvsIn :: PrepQuery R (UserId, [OpaqueConvId]) (OpaqueConvId, Maybe RemoteConvId, Maybe Domain) +selectUserConvsIn = "select conv, conv_remote_id, conv_remote_domain from user where user = ? and conv in ? order by conv" -selectUserConvsFrom :: PrepQuery R (UserId, OpaqueConvId) (Identity OpaqueConvId) -selectUserConvsFrom = "select conv from user where user = ? and conv > ? order by conv" +selectUserConvsFrom :: PrepQuery R (UserId, OpaqueConvId) (OpaqueConvId, Maybe RemoteConvId, Maybe Domain) +selectUserConvsFrom = "select conv, conv_remote_id, conv_remote_domain from user where user = ? and conv > ? order by conv" --- FUTUREWORK(federation): unify types with queries above -insertUserConv :: PrepQuery W (UserId, ConvId) () -insertUserConv = "insert into user (user, conv) values (?, ?)" +insertUserConv :: PrepQuery W (UserId, OpaqueConvId, Maybe RemoteConvId, Maybe Domain) () +insertUserConv = "insert into user (user, conv, conv_remote_id, conv_remote_domain) values (?, ?, ?, ?)" -deleteUserConv :: PrepQuery W (UserId, ConvId) () +deleteUserConv :: PrepQuery W (UserId, OpaqueConvId) () deleteUserConv = "delete from user where user = ? and conv = ?" -- Members ------------------------------------------------------------------ type MemberStatus = Int32 -selectMember :: PrepQuery R (ConvId, UserId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe Bool, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) -selectMember = "select user, service, provider, status, otr_muted, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from member where conv = ? and user = ?" +selectMember :: PrepQuery R (ConvId, OpaqueUserId) (OpaqueUserId, Maybe RemoteUserId, Maybe Domain, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe Bool, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) +selectMember = "select user, user_remote_id, user_remote_domain, service, provider, status, otr_muted, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from member where conv = ? and user = ?" -selectMembers :: PrepQuery R (Identity [ConvId]) (ConvId, UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe Bool, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) -selectMembers = "select conv, user, service, provider, status, otr_muted, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from member where conv in ?" +selectMembers :: PrepQuery R (Identity [ConvId]) (ConvId, OpaqueUserId, Maybe RemoteUserId, Maybe Domain, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe Bool, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName) +selectMembers = "select conv, user, user_remote_id, user_remote_domain, service, provider, status, otr_muted, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role from member where conv in ?" -insertMember :: PrepQuery W (ConvId, UserId, Maybe ServiceId, Maybe ProviderId, RoleName) () -insertMember = "insert into member (conv, user, service, provider, status, conversation_role) values (?, ?, ?, ?, 0, ?)" +insertMember :: PrepQuery W (ConvId, OpaqueUserId, Maybe RemoteUserId, Maybe Domain, Maybe ServiceId, Maybe ProviderId, RoleName) () +insertMember = "insert into member (conv, user, user_remote_id, user_remote_domain, service, provider, status, conversation_role) values (?, ?, ?, ?, ?, ?, 0, ?)" removeMember :: PrepQuery W (ConvId, OpaqueUserId) () removeMember = "delete from member where conv = ? and user = ?" -updateOtrMemberMuted :: PrepQuery W (Bool, Maybe Text, ConvId, UserId) () +updateOtrMemberMuted :: PrepQuery W (Bool, Maybe Text, ConvId, OpaqueUserId) () updateOtrMemberMuted = "update member set otr_muted = ?, otr_muted_ref = ? where conv = ? and user = ?" -updateOtrMemberMutedStatus :: PrepQuery W (MutedStatus, Maybe Text, ConvId, UserId) () +updateOtrMemberMutedStatus :: PrepQuery W (MutedStatus, Maybe Text, ConvId, OpaqueUserId) () updateOtrMemberMutedStatus = "update member set otr_muted_status = ?, otr_muted_ref = ? where conv = ? and user = ?" -updateOtrMemberArchived :: PrepQuery W (Bool, Maybe Text, ConvId, UserId) () +updateOtrMemberArchived :: PrepQuery W (Bool, Maybe Text, ConvId, OpaqueUserId) () updateOtrMemberArchived = "update member set otr_archived = ?, otr_archived_ref = ? where conv = ? and user = ?" -updateMemberHidden :: PrepQuery W (Bool, Maybe Text, ConvId, UserId) () +updateMemberHidden :: PrepQuery W (Bool, Maybe Text, ConvId, OpaqueUserId) () updateMemberHidden = "update member set hidden = ?, hidden_ref = ? where conv = ? and user = ?" -updateMemberConvRoleName :: PrepQuery W (RoleName, ConvId, UserId) () +updateMemberConvRoleName :: PrepQuery W (RoleName, ConvId, OpaqueUserId) () updateMemberConvRoleName = "update member set conversation_role = ? where conv = ? and user = ?" -- Clients ------------------------------------------------------------------ diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index 5ebc51c3be0..4692c52c758 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -46,9 +46,12 @@ import Imports -- BotMember ------------------------------------------------------------------ -newtype BotMember = BotMember {fromBotMember :: Member} +-- | For now we assume bots to always be local +-- +-- FUTUREWORK(federation): allow remote bots +newtype BotMember = BotMember {fromBotMember :: LocalMember} -newBotMember :: Member -> Maybe BotMember +newBotMember :: LocalMember -> Maybe BotMember newBotMember m = const (BotMember m) <$> memService m botMemId :: BotMember -> BotId @@ -64,7 +67,7 @@ addBotMember orig s bot cnv now = do retry x5 $ batch $ do setType BatchLogged setConsistency Quorum - addPrepQuery insertUserConv (botUserId bot, cnv) + addPrepQuery insertUserConv (botUserId bot, makeIdOpaque cnv, Nothing, Nothing) addPrepQuery insertBot (cnv, bot, sid, pid) let e = Event MemberJoin cnv orig now (Just . EdMembersJoin . SimpleMembers $ (fmap toSimpleMember [botUserId bot])) let mem = (newMember (botUserId bot)) {memService = Just s} diff --git a/services/galley/src/Galley/Data/Types.hs b/services/galley/src/Galley/Data/Types.hs index 88334a1d22e..16a5e9f3f61 100644 --- a/services/galley/src/Galley/Data/Types.hs +++ b/services/galley/src/Galley/Data/Types.hs @@ -40,7 +40,7 @@ import Data.Id import Data.Misc (Milliseconds) import Data.Range import qualified Data.Text.Ascii as Ascii -import Galley.Types (Access, AccessRole, ConvType (..), Member (..), ReceiptMode) +import Galley.Types (Access, AccessRole, ConvType (..), Member, ReceiptMode) import Imports import OpenSSL.EVP.Digest (digestBS, getDigestByName) import OpenSSL.Random (randBytes) @@ -62,7 +62,7 @@ data Conversation = Conversation convMessageTimer :: Maybe Milliseconds, convReceiptMode :: Maybe ReceiptMode } - deriving (Eq, Show, Generic) + deriving (Show) isSelfConv :: Conversation -> Bool isSelfConv = (SelfConv ==) . convType diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs index a0e5448c639..e1f29fdbf30 100644 --- a/services/galley/src/Galley/Intra/Push.hs +++ b/services/galley/src/Galley/Intra/Push.hs @@ -54,9 +54,12 @@ import Control.Lens ((&), (.~), (^.), makeLenses, set, view) import Control.Monad.Catch import Control.Retry import Data.Aeson (Object) -import Data.Id +import Data.Id (ConnId, UserId) +import qualified Data.Id as Id +import Data.IdMapping (IdMapping, MappedOrLocalId (Local, Mapped)) import Data.Json.Util import Data.List.Extra (chunksOf) +import Data.List.NonEmpty (nonEmpty) import Data.List1 import Data.Misc import Data.Range @@ -84,32 +87,38 @@ pushEventJson :: PushEvent -> Object pushEventJson (ConvEvent e) = toJSONObject e pushEventJson (TeamEvent e) = toJSONObject e -data Recipient = Recipient - { _recipientUserId :: UserId, +type Recipient = RecipientBy (MappedOrLocalId Id.U) + +data RecipientBy user = Recipient + { _recipientUserId :: user, _recipientClients :: RecipientClients } + deriving stock (Functor, Foldable, Traversable) -makeLenses ''Recipient +makeLenses ''RecipientBy recipient :: Member -> Recipient -recipient m = Recipient (memId m) RecipientClientsAll +recipient = userRecipient . memId -userRecipient :: UserId -> Recipient +userRecipient :: user -> RecipientBy user userRecipient u = Recipient u RecipientClientsAll -data Push = Push +type Push = PushTo (MappedOrLocalId Id.U) + +data PushTo user = Push { _pushConn :: Maybe ConnId, _pushTransient :: Bool, _pushRoute :: Gundeck.Route, _pushNativePriority :: Maybe Gundeck.Priority, _pushAsync :: Bool, pushOrigin :: UserId, - pushRecipients :: List1 Recipient, + pushRecipients :: List1 (RecipientBy user), pushJson :: Object, pushRecipientListType :: Teams.ListType } + deriving stock (Functor, Foldable, Traversable) -makeLenses ''Push +makeLenses ''PushTo newPush1 :: Teams.ListType -> UserId -> PushEvent -> List1 Recipient -> Push newPush1 recipientListType from e rr = @@ -138,11 +147,34 @@ pushSome :: [Push] -> Galley () pushSome [] = return () pushSome (x : xs) = push (list1 x xs) +push :: List1 Push -> Galley () +push ps = do + let (localPushes, remotePushes) = foldMap (bimap toList toList . splitPush) (toList ps) + traverse_ (pushLocal . List1) (nonEmpty localPushes) + traverse_ (pushRemote . List1) (nonEmpty remotePushes) + where + splitPush :: Push -> (Maybe (PushTo UserId), Maybe (PushTo (IdMapping Id.U))) + splitPush p = + (mkPushTo localRecipients p, mkPushTo remoteRecipients p) + where + (localRecipients, remoteRecipients) = + partitionEithers . fmap localOrRemoteRecipient . toList $ pushRecipients p + -- + localOrRemoteRecipient :: RecipientBy (MappedOrLocalId Id.U) -> Either (RecipientBy UserId) (RecipientBy (IdMapping Id.U)) + localOrRemoteRecipient rcp = case _recipientUserId rcp of + Local localId -> Left $ rcp {_recipientUserId = localId} + Mapped idMapping -> Right $ rcp {_recipientUserId = idMapping} + -- + mkPushTo :: [RecipientBy a] -> PushTo b -> Maybe (PushTo a) + mkPushTo recipients p = + nonEmpty recipients <&> \nonEmptyRecipients -> + p {pushRecipients = List1 nonEmptyRecipients} + -- | Asynchronously send multiple pushes, aggregating them into as -- few requests as possible, such that no single request targets -- more than 128 recipients. -push :: List1 Push -> Galley () -push ps = do +pushLocal :: List1 (PushTo UserId) -> Galley () +pushLocal ps = do limit <- fanoutLimit -- Do not fan out for very large teams let (async, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) @@ -181,6 +213,12 @@ push ps = do && (length (pushRecipients p) <= (fromIntegral $ fromRange limit)) ) +-- instead of IdMapping, we could also just take qualified IDs +pushRemote :: List1 (PushTo (IdMapping Id.U)) -> Galley () +pushRemote _ps = do + -- FUTUREWORK(federation, #1261): send these to the other backends + pure () + ----------------------------------------------------------------------------- -- Helpers diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 8bec226b6fd..a9175822899 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -46,7 +46,7 @@ import Data.Range import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Ascii as Ascii -import Galley.Types +import Galley.Types hiding (InternalMember (..), Member) import Galley.Types.Conversations.Roles import qualified Galley.Types.Teams as Teams import Gundeck.Types.Notification @@ -58,6 +58,7 @@ import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import TestHelpers import TestSetup +import Wire.API.Conversation.Member (Member (..)) tests :: IO TestSetup -> TestTree tests s = @@ -873,7 +874,7 @@ postMembersOk2 = do postMembers bob (singleton chuck) conv !!! const 204 === statusCode chuck' <- responseJsonUnsafe <$> (getSelfMember chuck conv chuck') (Just chuck) + assertEqual "wrong self member" (Just (makeIdOpaque chuck)) (memId <$> chuck') postMembersOk3 :: TestM () postMembersOk3 = do @@ -1013,7 +1014,7 @@ putMemberOk update = do -- Expected member state let memberBob = Member - { memId = bob, + { memId = makeIdOpaque bob, memService = Nothing, memOtrMuted = fromMaybe False (mupOtrMute update), memOtrMutedStatus = mupOtrMuteStatus update, @@ -1146,13 +1147,13 @@ removeUser = do mems1 <- fmap cnvMembers . responseJsonUnsafe <$> getConv alice conv1 mems2 <- fmap cnvMembers . responseJsonUnsafe <$> getConv alice conv2 mems3 <- fmap cnvMembers . responseJsonUnsafe <$> getConv alice conv3 - let other u = find ((== u) . omId) . cmOthers + let other u = find ((== makeIdOpaque u) . omId) . cmOthers liftIO $ do (mems1 >>= other bob) @?= Nothing (mems2 >>= other bob) @?= Nothing - (mems2 >>= other carl) @?= Just (OtherMember carl Nothing roleNameWireAdmin) + (mems2 >>= other carl) @?= Just (OtherMember (makeIdOpaque carl) Nothing roleNameWireAdmin) (mems3 >>= other bob) @?= Nothing - (mems3 >>= other carl) @?= Just (OtherMember carl Nothing roleNameWireAdmin) + (mems3 >>= other carl) @?= Just (OtherMember (makeIdOpaque carl) Nothing roleNameWireAdmin) where matchMemberLeave conv u n = do let e = List1.head (WS.unpackPayload n) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index e2cdaa04de7..243dcff24df 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -52,7 +52,7 @@ import qualified Data.UUID as UUID import Data.UUID.V4 import qualified Galley.Options as Opts import qualified Galley.Run as Run -import Galley.Types +import Galley.Types hiding (InternalMember (..), Member) import Galley.Types.Conversations.Roles hiding (DeleteConversation) import qualified Galley.Types.Teams as Team import Galley.Types.Teams hiding (Event, EventType (..)) @@ -77,6 +77,7 @@ import Test.Tasty.HUnit import TestSetup import UnliftIO.Timeout import Web.Cookie +import Wire.API.Conversation.Member (Member (..)) import qualified Wire.API.Event.Team as TE import qualified Wire.API.Message.Proto as Proto @@ -877,14 +878,14 @@ assertConvMemberWithRole :: HasCallStack => RoleName -> ConvId -> UserId -> Test assertConvMemberWithRole r c u = getSelfMember u c !!! do const 200 === statusCode - const (Right u) === (fmap memId <$> responseJsonEither) + const (Right (makeIdOpaque u)) === (fmap memId <$> responseJsonEither) const (Right r) === (fmap memConvRoleName <$> responseJsonEither) assertConvMember :: HasCallStack => UserId -> ConvId -> TestM () assertConvMember u c = getSelfMember u c !!! do const 200 === statusCode - const (Right u) === (fmap memId <$> responseJsonEither) + const (Right (makeIdOpaque u)) === (fmap memId <$> responseJsonEither) assertNotConvMember :: HasCallStack => UserId -> ConvId -> TestM () assertNotConvMember u c = @@ -940,8 +941,8 @@ assertConvWithRole r t c s us n mt role = do assertEqual "type" (Just t) (cnvType <$> cnv) assertEqual "creator" (Just c) (cnvCreator <$> cnv) assertEqual "message_timer" (Just mt) (cnvMessageTimer <$> cnv) - assertEqual "self" (Just s) (memId <$> _self) - assertEqual "others" (Just $ Set.fromList us) (Set.fromList . map omId . toList <$> others) + assertEqual "self" (Just (makeIdOpaque s)) (memId <$> _self) + assertEqual "others" (Just . Set.fromList $ makeIdOpaque <$> us) (Set.fromList . map omId . toList <$> others) assertEqual "creator is always and admin" (Just roleNameWireAdmin) (memConvRoleName <$> _self) assertBool "others role" (all (\x -> x == role) $ fromMaybe (error "Cannot be null") ((map omConvRoleName . toList <$> others))) assertBool "otr muted not false" (Just False == (memOtrMuted <$> _self)) From 42c0b675e6d02556f9200c0ad55392f5bae53197 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Thu, 18 Jun 2020 14:27:26 +0200 Subject: [PATCH 5/7] Bump http-client (#1138) Bump http-client Co-authored-by: Matthias Fischmann --- .../brig/test/integration/API/User/Auth.hs | 4 ++- services/spar/test-integration/Util/Core.hs | 2 +- stack.yaml | 2 +- stack.yaml.lock | 36 +++++++++---------- 4 files changed, 23 insertions(+), 21 deletions(-) diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 64b18985646..f93f0695d1c 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -54,6 +54,7 @@ import Data.Time.Clock import qualified Data.UUID.V4 as UUID import qualified Data.ZAuth.Token as ZAuth import Imports +import Network.HTTP.Client (equivCookie) import qualified Network.Wai.Utilities.Error as Error import Test.Tasty import Test.Tasty.HUnit @@ -603,7 +604,8 @@ testNewPersistentCookie config b = do const 200 === statusCode const Nothing =/= getHeader "Set-Cookie" const (Just "access_token") =~= responseBody - liftIO $ assertEqual "cookie" c' (decodeCookie _rs) + -- we got a new cookie value, but the key is the same + liftIO $ assertBool "cookie" (c' `equivCookie` decodeCookie _rs) -- Refresh with the new cookie should succeed -- (without advertising yet another new cookie). post (b . path "/access" . cookie c') !!! do diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 3f005c1843a..756e040bf9b 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -615,7 +615,7 @@ endpointToURL endpoint urlpath = either err pure url shouldRespondWith :: forall a. - (HasCallStack, Show a, Eq a) => + (HasCallStack, Show a) => Http a -> (a -> Bool) -> TestSpar () diff --git a/stack.yaml b/stack.yaml index 24f377f0c8c..ae2016d1ec3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -133,7 +133,7 @@ extra-deps: commit: fe08618e81dee9b7a25f10f5b9d26d1ff1837c79 # master (Mar 25, 2020) - git: https://github.com/wireapp/http-client - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf # master (Feb 4, 2020) + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd # master (Jun 16, 2020) subdirs: - http-client - http-client-openssl diff --git a/stack.yaml.lock b/stack.yaml.lock index a3ba5941573..6d251849586 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -316,35 +316,35 @@ packages: - completed: subdir: http-client cabal-file: - size: 5320 - sha256: 940ca1c45282ef0b18ff9e535b086c4a422f3ebc8372183c1a9432b0f38f1a15 + size: 5350 + sha256: 868faa3479fa330ac6eb897e6888296a32f10a249d2d91ece5ab2add9f0c24d4 name: http-client - version: 0.6.4 + version: 0.7.0 git: https://github.com/wireapp/http-client pantry-tree: - size: 3127 - sha256: fc8c48d7bdccaf2f761f3c6216f6a592ba4424735c9a8544cc13fae9e48a563e - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + size: 3129 + sha256: 355d13d4b018ab32ad3ba1b88d8d183c4f673efb3a8109d3b0260776b2473ec0 + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd original: subdir: http-client git: https://github.com/wireapp/http-client - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd - completed: subdir: http-client-openssl cabal-file: size: 1494 - sha256: 36a5a54e4c7effe1e67310d9fc932e6a9d92a3d865ceb29ae38816d8335ae3bc + sha256: 423d74b93d5b2a79991340da8d2cd8fccd496fb470483bad8c73857200509e4e name: http-client-openssl - version: 0.3.0.0 + version: 0.3.1.0 git: https://github.com/wireapp/http-client pantry-tree: size: 387 - sha256: 0f1784da10763596a76d3bc8a6c5ab86fab24a120de5faa6b6d0db78209a8d1e - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + sha256: c9265105d25badaa471e8d3d0eb493ebcba3ce17b4d430d2db70b6a0a4f90821 + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd original: subdir: http-client-openssl git: https://github.com/wireapp/http-client - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd - completed: subdir: http-client-tls cabal-file: @@ -356,27 +356,27 @@ packages: pantry-tree: size: 435 sha256: 13722b74ba7edde9163e5c194af168fc98c4dc419c37fd42fada45f5a89d2042 - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd original: subdir: http-client-tls git: https://github.com/wireapp/http-client - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd - completed: subdir: http-conduit cabal-file: size: 2910 - sha256: 22d6108caaf4a661a822462e53e18915b229a9dc75f397a29df666dc9e92e903 + sha256: 4e0024c25cb1a6c5a20b687201c78a7a2c781a582f669d0f88125d113e65c326 name: http-conduit version: 2.3.7.3 git: https://github.com/wireapp/http-client pantry-tree: size: 1074 - sha256: 03b9ae4a6d67b5fd875f2c898e04fb45d71db92a954180d906c896312fe6dfb9 - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + sha256: ec54f41b6997eabc01aa5e65a584bf37a39efb57a9eaad8f1e8005137f32c625 + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd original: subdir: http-conduit git: https://github.com/wireapp/http-client - commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf + commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd - completed: hackage: template-0.2.0.10@sha256:f822de4d34c45bc84b33a61bc112c15fedee6fa6dc414c62b10456395a868f85,987 pantry-tree: From 94a8a3493fcea980310606c912d00f6cc987d4dc Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Fri, 19 Jun 2020 13:03:46 +0200 Subject: [PATCH 6/7] Find undead users in elasticsearch (#1137) Co-authored-by: Matthias Fischmann --- docs/reference/elastic-search.md | 7 ++ services/brig/src/Brig/Options.hs | 9 +- stack.yaml | 1 + tools/db/find-undead/Makefile | 25 +++++ tools/db/find-undead/README.md | 23 ++++ tools/db/find-undead/find-undead.cabal | 48 +++++++++ tools/db/find-undead/package.yaml | 39 +++++++ tools/db/find-undead/src/Main.hs | 62 +++++++++++ tools/db/find-undead/src/Options.hs | 88 +++++++++++++++ tools/db/find-undead/src/Work.hs | 143 +++++++++++++++++++++++++ 10 files changed, 444 insertions(+), 1 deletion(-) create mode 100644 tools/db/find-undead/Makefile create mode 100644 tools/db/find-undead/README.md create mode 100644 tools/db/find-undead/find-undead.cabal create mode 100644 tools/db/find-undead/package.yaml create mode 100644 tools/db/find-undead/src/Main.hs create mode 100644 tools/db/find-undead/src/Options.hs create mode 100644 tools/db/find-undead/src/Work.hs diff --git a/docs/reference/elastic-search.md b/docs/reference/elastic-search.md index cd12986a604..8c2ba055f07 100644 --- a/docs/reference/elastic-search.md +++ b/docs/reference/elastic-search.md @@ -112,6 +112,13 @@ REFRESH_INTERVAL= Now you can delete the old index. +**NOTE**: There is a bug hidden when using this way. Sometimes a user won't get +deleted from the index. Attempts at reproducing this issue in a simpler +environment have failed. As a workaround, there is a tool in +[tools/db/find-undead](../../tools/db/find-undead) which can be used to find the +undead users right after the migration. If they exist, please run refill the ES +documents from cassandra as described [above](#refill-es-documents-from-cassandra) + ## Recreate an index (Requires downtime) When analysis settings of an index need to be changed, e.g. for changes diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 098879d30a0..4c4acc3e008 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -56,7 +56,14 @@ data ElasticSearchOpts = ElasticSearchOpts url :: !Text, -- | The name of the ElasticSearch user index index :: !Text, - -- | An additional index to write user data, useful while migrating to a new index + -- | An additional index to write user data, useful while migrating to a new + -- index. + -- There is a bug hidden when using this option. Sometimes a user won't get + -- deleted from the index. Attempts at reproducing this issue in a simpler + -- environment have failed. As a workaround, there is a tool in + -- tools/db/find-undead which can be used to find the undead users right + -- after the migration, if they exist, we can run the reindexing to get data + -- in elasticsearch in a consistent state. additionalWriteIndex :: !(Maybe Text) } deriving (Show, Generic) diff --git a/stack.yaml b/stack.yaml index ae2016d1ec3..b2ad9cd9ad9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,6 +38,7 @@ packages: - tools/db/migrate-sso-feature-flag - tools/db/service-backfill - tools/db/billing-team-member-backfill +- tools/db/find-undead - tools/makedeb - tools/stern diff --git a/tools/db/find-undead/Makefile b/tools/db/find-undead/Makefile new file mode 100644 index 00000000000..835c3e7ce22 --- /dev/null +++ b/tools/db/find-undead/Makefile @@ -0,0 +1,25 @@ +LANG := en_US.UTF-8 + +SHELL := /usr/bin/env bash + +NAME := find-undead + +default: all + +all: install + +.PHONY: clean +clean: + stack clean $NAME + +.PHONY: compile +compile: + stack build . + +.PHONY: install +install: + stack install --pedantic --local-bin-path=dist . + +.PHONY: fast +fast: + stack install --fast --local-bin-path=dist . diff --git a/tools/db/find-undead/README.md b/tools/db/find-undead/README.md new file mode 100644 index 00000000000..739d49c1ce8 --- /dev/null +++ b/tools/db/find-undead/README.md @@ -0,0 +1,23 @@ +## Find certain inconsistencies between ES and Cassandra user data + +Context: https://github.com/zinfra/backend-issues/issues/1493 + +This script identifies users that are still visible on ES, but are +marked as deleted on C*. + +It outputs the time at which users have been marked as deleted in C* +so that you can decide whether what you are seeing may be a race +condition (eg., big team is being deleted while you run the script, +and users will be gone from ES a moment after you log them as +inconsistencies). + +### How to run this + +```sh +export BRIG_HOST=... # ip address of galley cassandra DB node +export BRIG_KEYSPACE=brig + +ssh -v -f ubuntu@${BRIG_HOST} -L 2021:${BRIG_HOST}:9042 -N + +./dist/find-undead --cassandra-host-brig=localhost --cassandra-port-brig=2021 --cassandra-keyspace-brig=${BRIG_KEYSPACE} +``` diff --git a/tools/db/find-undead/find-undead.cabal b/tools/db/find-undead/find-undead.cabal new file mode 100644 index 00000000000..c4d8b60dbab --- /dev/null +++ b/tools/db/find-undead/find-undead.cabal @@ -0,0 +1,48 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f3ea09e1b515654dee71de77dde62a14c78830b80217803ef50d0f2d89871610 + +name: find-undead +version: 1.0.0 +synopsis: Backfill billing_team_member table +category: Network +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2020 Wire Swiss GmbH +license: AGPL-3 +build-type: Simple + +executable find-undead + main-is: Main.hs + other-modules: + Options + Work + Paths_find_undead + hs-source-dirs: + src + default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts + build-depends: + aeson + , base + , bloodhound + , brig-types + , cassandra-util + , conduit + , containers + , galley-types + , http-client + , imports + , lens + , optparse-applicative + , text + , time + , tinylog + , types-common + , unliftio + , uuid + default-language: Haskell2010 diff --git a/tools/db/find-undead/package.yaml b/tools/db/find-undead/package.yaml new file mode 100644 index 00000000000..8acf1a7ae18 --- /dev/null +++ b/tools/db/find-undead/package.yaml @@ -0,0 +1,39 @@ +defaults: + local: ../../../package-defaults.yaml +name: find-undead +version: '1.0.0' +synopsis: Backfill billing_team_member table +category: Network +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2020 Wire Swiss GmbH +license: AGPL-3 +ghc-options: +- -funbox-strict-fields +- -threaded +- -with-rtsopts=-N +- -with-rtsopts=-T +- -rtsopts +dependencies: +- aeson +- base +- cassandra-util +- containers +- galley-types +- brig-types +- imports +- optparse-applicative +- bloodhound +- http-client +- text +- lens +- tinylog +- uuid +- types-common +- unliftio +- conduit +- time +executables: + find-undead: + main: Main.hs + source-dirs: src diff --git a/tools/db/find-undead/src/Main.hs b/tools/db/find-undead/src/Main.hs new file mode 100644 index 00000000000..c3d7efd1399 --- /dev/null +++ b/tools/db/find-undead/src/Main.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Main + ( main, + ) +where + +import Cassandra as C +import Cassandra.Settings as C +import Data.Text as Text +import qualified Database.Bloodhound as ES +import Imports +import qualified Network.HTTP.Client as HTTP +import Options as O +import Options.Applicative +import qualified System.Logger as Log +import Work + +main :: IO () +main = do + s <- execParser (info (helper <*> settingsParser) desc) + lgr <- initLogger + cas <- initCas (setCasBrig s) lgr + mgr <- HTTP.newManager HTTP.defaultManagerSettings + let es = initES (setESBrig s) mgr + runCommand lgr cas es (esIndex $ setESBrig s) (esMapping $ setESBrig s) + where + desc = + header "find-undead" + <> progDesc "finds users which are in ES but not in cassandra" + <> fullDesc + initLogger = + Log.new + . Log.setOutput Log.StdOut + . Log.setBufSize 0 + $ Log.defSettings + initCas cas l = + C.init + . C.setLogger (C.mkLogger l) + . C.setContacts (cHosts cas) [] + . C.setPortNumber (fromIntegral $ cPort cas) + . C.setKeyspace (cKeyspace cas) + . C.setProtocolVersion C.V4 + $ C.defSettings + initES es = ES.mkBHEnv (ES.Server . Text.pack $ "http://" <> esHost es <> ":" <> show (esPort es)) diff --git a/tools/db/find-undead/src/Options.hs b/tools/db/find-undead/src/Options.hs new file mode 100644 index 00000000000..b45adcd2627 --- /dev/null +++ b/tools/db/find-undead/src/Options.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Options where + +import qualified Cassandra as C +import qualified Data.Text as Text +import Imports +import Options.Applicative + +data MigratorSettings = MigratorSettings + { setCasBrig :: CassandraSettings, + setESBrig :: ElasticSettings + } + deriving (Show) + +data CassandraSettings = CassandraSettings + { cHosts :: !String, + cPort :: !Word16, + cKeyspace :: !C.Keyspace + } + deriving (Show) + +data ElasticSettings = ElasticSettings + { esHost :: !String, + esPort :: !Word16, + esIndex :: !String, + esMapping :: !String + } + deriving (Show) + +settingsParser :: Parser MigratorSettings +settingsParser = + MigratorSettings + <$> cassandraSettingsParser "brig" + <*> esSettingsParser + +cassandraSettingsParser :: String -> Parser CassandraSettings +cassandraSettingsParser ks = + CassandraSettings + <$> strOption + ( long ("cassandra-host-" ++ ks) + <> metavar "HOST" + <> help ("Cassandra Host for: " ++ ks) + <> value "localhost" + <> showDefault + ) + <*> option + auto + ( long ("cassandra-port-" ++ ks) + <> metavar "PORT" + <> help ("Cassandra Port for: " ++ ks) + <> value 9042 + <> showDefault + ) + <*> ( C.Keyspace . Text.pack + <$> strOption + ( long ("cassandra-keyspace-" ++ ks) + <> metavar "STRING" + <> help ("Cassandra Keyspace for: " ++ ks) + <> value (ks ++ "_test") + <> showDefault + ) + ) + +esSettingsParser :: Parser ElasticSettings +esSettingsParser = + ElasticSettings + <$> strOption (long "es-host" <> value "localhost") + <*> option auto (long "es-port" <> value 9200) + <*> strOption (long "es-index" <> value "directory_test") + <*> strOption (long "es-mapping" <> value "user") diff --git a/tools/db/find-undead/src/Work.hs b/tools/db/find-undead/src/Work.hs new file mode 100644 index 00000000000..32757e22c12 --- /dev/null +++ b/tools/db/find-undead/src/Work.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Work where + +import Brig.Types.Intra (AccountStatus (..)) +import Cassandra +import Cassandra.Util (Writetime, writeTimeToUTC) +import Conduit +import Control.Lens (_1, _2, view) +import Data.Aeson ((.:), FromJSON) +import qualified Data.Aeson as Aeson +import qualified Data.Conduit.List as C +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.UUID +import qualified Database.Bloodhound as ES +import Imports +import System.Logger (Logger) +import qualified System.Logger as Log + +runCommand :: Logger -> ClientState -> ES.BHEnv -> String -> String -> IO () +runCommand l cas es indexStr mappingStr = do + let index = ES.IndexName $ Text.pack indexStr + mapping = ES.MappingName $ Text.pack mappingStr + runConduit + $ transPipe (ES.runBH es) + $ getScrolled index mapping + .| C.iterM (logProgress l) + .| C.mapM + ( \uuids -> do + fromCas <- runClient cas $ usersInCassandra uuids + pure (uuids, fromCas) + ) + .| C.mapM_ (logDifference l) + +---------------------------------------------------------------------------- +-- Queries + +logProgress :: MonadIO m => Logger -> [UUID] -> m () +logProgress l uuids = Log.info l $ Log.field "Progress" (show $ length uuids) + +logDifference :: Logger -> ([UUID], [(UUID, Maybe AccountStatus, Maybe (Writetime ()))]) -> ES.BH IO () +logDifference l (uuidsFromES, fromCas) = do + let noStatusUuidsFromCas = filter (isNothing . view _2) fromCas + deletedUuidsFromCas = filter ((== Just Deleted) . view _2) fromCas + extraUuids = Set.difference (Set.fromList uuidsFromES) (Set.fromList $ map (view _1) fromCas) + mapM_ (logUUID l "NoStatus") noStatusUuidsFromCas + mapM_ (logUUID l "Deleted") deletedUuidsFromCas + mapM_ (logUUID l "Extra" . (,Nothing,Nothing)) extraUuids + +logUUID :: MonadIO m => Logger -> ByteString -> (UUID, Maybe AccountStatus, Maybe (Writetime ())) -> m () +logUUID l f (uuid, _, time) = + Log.info l $ + Log.msg f + . Log.field "uuid" (show uuid) + . Log.field "write time" (show $ writeTimeToUTC <$> time) + +getScrolled :: (ES.MonadBH m, MonadThrow m) => ES.IndexName -> ES.MappingName -> ConduitM () [UUID] m () +getScrolled index mapping = processRes =<< lift (ES.getInitialScroll index mapping esSearch) + where + processRes :: (ES.MonadBH m, MonadThrow m) => Either ES.EsError (ES.SearchResult User) -> ConduitM () [UUID] m () + processRes = \case + Left e -> throwM $ EsError e + Right res -> + case map docId $ extractHits res of + [] -> pure () + ids -> do + yield ids + processRes + =<< (\scrollId -> lift (ES.advanceScroll scrollId 120)) + =<< extractScrollId res + +esFilter :: ES.Filter +esFilter = ES.Filter $ ES.QueryExistsQuery (ES.FieldName "normalized") + +chunkSize :: Int +chunkSize = 10000 + +esSearch :: ES.Search +esSearch = (ES.mkSearch Nothing (Just esFilter)) {ES.size = ES.Size chunkSize} + +extractHits :: ES.SearchResult User -> [User] +extractHits = mapMaybe ES.hitSource . ES.hits . ES.searchHits + +extractScrollId :: MonadThrow m => ES.SearchResult a -> m ES.ScrollId +extractScrollId res = maybe (throwM NoScrollId) pure (ES.scrollId res) + +usersInCassandra :: [UUID] -> Client [(UUID, Maybe AccountStatus, Maybe (Writetime ()))] +usersInCassandra users = retry x1 $ query cql (params Quorum (Identity users)) + where + cql :: PrepQuery R (Identity [UUID]) (UUID, Maybe AccountStatus, Maybe (Writetime ())) + cql = "SELECT id, status, writetime(status) from user where id in ?" + +newtype User = User {docId :: UUID} + +instance FromJSON User where + parseJSON = Aeson.withObject "User" $ \o -> User <$> o .: "id" + +data WorkError + = NoScrollId + | EsError ES.EsError + deriving (Show, Eq) + +instance Exception WorkError + +type Name = Text + +-- FUTUREWORK: you can avoid this by loading brig-the-service as a library: +-- @"services/brig/src/Brig/Data/Instances.hs:165:instance Cql AccountStatus where"@ +instance Cql AccountStatus where + ctype = Tagged IntColumn + + toCql Active = CqlInt 0 + toCql Suspended = CqlInt 1 + toCql Deleted = CqlInt 2 + toCql Ephemeral = CqlInt 3 + + fromCql (CqlInt i) = case i of + 0 -> return Active + 1 -> return Suspended + 2 -> return Deleted + 3 -> return Ephemeral + n -> fail $ "unexpected account status: " ++ show n + fromCql _ = fail "account status: int expected" From 538ff3b7f0fa73cb9036507194d128740deaeeb3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 19 Jun 2020 16:45:40 +0200 Subject: [PATCH 7/7] CHANGELOG --- CHANGELOG.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6aacc9214eb..6d7442a437b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,25 @@ +# 2020-06-19 + +## Release Notes + +- run galley schema migrations +- no need to upgrade nginz + +## New Features + +* Add team level flag for digital signtaures (#1132) + +## Bug fixes + +* Bump http-client (#1138) + +## Internal changes + +* Script for finding undead users in elasticsearch (#1137) +* DB changes for federation (#1070) +* Refactor team feature tests (#1136) + + # 2020-06-10 ## Release Notes