From aa014bf2aae63df5906181b2855fc6cac3c63a9d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 6 Aug 2024 14:00:27 +0200 Subject: [PATCH 01/48] UserStore.Cassandra: Dedup embed call --- .../src/Wire/UserStore/Cassandra.hs | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index b62e615220e..d835a265f7b 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -16,19 +16,19 @@ import Wire.UserStore.Unique interpretUserStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor UserStore r interpretUserStoreCassandra casClient = interpret $ - runEmbedded (runClient casClient) . \case + runEmbedded (runClient casClient) . embed . \case GetUser uid -> getUserImpl uid - UpdateUser uid update -> embed $ updateUserImpl uid update - UpdateUserHandleEither uid update -> embed $ updateUserHandleEitherImpl uid update - DeleteUser user -> embed $ deleteUserImpl user - LookupHandle hdl -> embed $ lookupHandleImpl LocalQuorum hdl - GlimpseHandle hdl -> embed $ lookupHandleImpl One hdl - LookupStatus uid -> embed $ lookupStatusImpl uid - IsActivated uid -> embed $ isActivatedImpl uid - LookupLocale uid -> embed $ lookupLocaleImpl uid - -getUserImpl :: (Member (Embed Client) r) => UserId -> Sem r (Maybe StoredUser) -getUserImpl uid = embed $ do + UpdateUser uid update -> updateUserImpl uid update + UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update + DeleteUser user -> deleteUserImpl user + LookupHandle hdl -> lookupHandleImpl LocalQuorum hdl + GlimpseHandle hdl -> lookupHandleImpl One hdl + LookupStatus uid -> lookupStatusImpl uid + IsActivated uid -> isActivatedImpl uid + LookupLocale uid -> lookupLocaleImpl uid + +getUserImpl :: UserId -> Client (Maybe StoredUser) +getUserImpl uid = do mUserTuple <- retry x1 $ query1 selectUser (params LocalQuorum (Identity uid)) pure $ asRecord <$> mUserTuple From cac29c25a90bc268629a39dd6cb816b50ab1de35 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 6 Aug 2024 14:03:57 +0200 Subject: [PATCH 02/48] Move all indexing operations to UserSearchSubsystem Pending: - Index Management - Search - Metrics - Update brig to use the new code (currently, brig is just broken) --- libs/brig-types/brig-types.cabal | 6 +- libs/brig-types/src/Brig/Types/Search.hs | 64 --- .../test/unit/Test/Brig/Types/User.hs | 2 - libs/cassandra-util/src/Cassandra/Exec.hs | 24 + libs/cassandra-util/src/Cassandra/Util.hs | 1 + .../src/Wire/GalleyAPIAccess.hs | 6 + .../src/Wire/GalleyAPIAccess/Rpc.hs | 20 + .../src/Wire/IndexedUserStore.hs | 16 + .../Wire/IndexedUserStore/ElasticSearch.hs | 142 +++++ .../src/Wire/UserSearch/Types.hs | 174 +++++++ .../src/Wire/UserSearchSubsystem.hs | 56 ++ .../Wire/UserSearchSubsystem/Interpreter.hs | 130 +++++ libs/wire-subsystems/src/Wire/UserStore.hs | 5 +- .../src/Wire/UserStore/Cassandra.hs | 35 ++ .../src/Wire/UserStore/IndexUser.hs | 207 ++++++++ .../unit/Wire/MockInterpreters/UserStore.hs | 2 + libs/wire-subsystems/wire-subsystems.cabal | 13 + services/brig/brig.cabal | 3 - services/brig/src/Brig/User/Search/Index.hs | 486 +----------------- .../brig/src/Brig/User/Search/Index/Types.hs | 230 --------- 20 files changed, 843 insertions(+), 779 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/IndexedUserStore.hs create mode 100644 libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs create mode 100644 libs/wire-subsystems/src/Wire/UserSearch/Types.hs create mode 100644 libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs create mode 100644 libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs create mode 100644 libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs delete mode 100644 services/brig/src/Brig/User/Search/Index/Types.hs diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 2f67b800eb5..3f19b147eab 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -73,16 +73,12 @@ library -funbox-strict-fields -Wredundant-constraints -Wunused-packages build-depends: - aeson >=2.0.1.0 - , attoparsec >=0.10 - , base >=4 && <5 - , bytestring + base >=4 && <5 , bytestring-conversion >=0.2 , cassandra-util , containers >=0.5 , imports , QuickCheck >=2.9 - , text >=0.11 , types-common >=0.16 , wire-api diff --git a/libs/brig-types/src/Brig/Types/Search.hs b/libs/brig-types/src/Brig/Types/Search.hs index 2a5006968f6..4ebc32ab2c6 100644 --- a/libs/brig-types/src/Brig/Types/Search.hs +++ b/libs/brig-types/src/Brig/Types/Search.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -20,23 +19,10 @@ module Brig.Types.Search ( TeamSearchInfo (..), - SearchVisibilityInbound (..), - defaultSearchVisibilityInbound, - searchVisibilityInboundFromFeatureStatus, ) where -import Cassandra qualified as C -import Data.Aeson -import Data.Attoparsec.ByteString -import Data.ByteString.Builder -import Data.ByteString.Conversion -import Data.ByteString.Lazy import Data.Id (TeamId) -import Data.Text.Encoding -import Imports -import Test.QuickCheck -import Wire.API.Team.Feature -- | Outbound search restrictions configured by team admin of the searcher. This -- value restricts the set of user that are searched. @@ -55,53 +41,3 @@ data TeamSearchInfo TeamOnly TeamId | -- | No search restrictions, all users are searched AllUsers - --- | Inbound search restrictions configured by team to-be-searched. Affects only --- full-text search (i.e. search on the display name and the handle), not exact --- handle search. -data SearchVisibilityInbound - = -- | The user can only be found by users from the same team - SearchableByOwnTeam - | -- | The user can by found by any user of any team - SearchableByAllTeams - deriving (Eq, Show) - -instance Arbitrary SearchVisibilityInbound where - arbitrary = elements [SearchableByOwnTeam, SearchableByAllTeams] - -instance ToByteString SearchVisibilityInbound where - builder SearchableByOwnTeam = "searchable-by-own-team" - builder SearchableByAllTeams = "searchable-by-all-teams" - -instance FromByteString SearchVisibilityInbound where - parser = - SearchableByOwnTeam - <$ string "searchable-by-own-team" - <|> SearchableByAllTeams - <$ string "searchable-by-all-teams" - -instance C.Cql SearchVisibilityInbound where - ctype = C.Tagged C.IntColumn - - toCql SearchableByOwnTeam = C.CqlInt 0 - toCql SearchableByAllTeams = C.CqlInt 1 - - fromCql (C.CqlInt 0) = pure SearchableByOwnTeam - fromCql (C.CqlInt 1) = pure SearchableByAllTeams - fromCql n = Left $ "Unexpected SearchVisibilityInbound: " ++ show n - -defaultSearchVisibilityInbound :: SearchVisibilityInbound -defaultSearchVisibilityInbound = SearchableByOwnTeam - -searchVisibilityInboundFromFeatureStatus :: FeatureStatus -> SearchVisibilityInbound -searchVisibilityInboundFromFeatureStatus FeatureStatusDisabled = SearchableByOwnTeam -searchVisibilityInboundFromFeatureStatus FeatureStatusEnabled = SearchableByAllTeams - -instance ToJSON SearchVisibilityInbound where - toJSON = String . decodeUtf8 . toStrict . toLazyByteString . builder - -instance FromJSON SearchVisibilityInbound where - parseJSON = withText "SearchVisibilityInbound" $ \str -> - case runParser (parser @SearchVisibilityInbound) (encodeUtf8 str) of - Left err -> fail err - Right result -> pure result diff --git a/libs/brig-types/test/unit/Test/Brig/Types/User.hs b/libs/brig-types/test/unit/Test/Brig/Types/User.hs index 6ca50562cb4..e345eb8e9b0 100644 --- a/libs/brig-types/test/unit/Test/Brig/Types/User.hs +++ b/libs/brig-types/test/unit/Test/Brig/Types/User.hs @@ -27,7 +27,6 @@ module Test.Brig.Types.User where import Brig.Types.Connection (UpdateConnectionsInternal (..)) import Brig.Types.Intra (NewUserScimInvitation (..), UserAccount (..)) -import Brig.Types.Search (SearchVisibilityInbound (..)) import Brig.Types.User (ManagedByUpdate (..), RichInfoUpdate (..)) import Data.Aeson import Imports @@ -50,7 +49,6 @@ roundtripTests = testRoundTripWithSwagger @EJPDRequestBody, testRoundTripWithSwagger @EJPDResponseBody, testRoundTrip @UpdateConnectionsInternal, - testRoundTrip @SearchVisibilityInbound, testRoundTripWithSwagger @UserAccount, testGroup "golden tests" $ [testCaseUserAccount] diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index c7d4c352a99..8ef7d64337c 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -27,6 +27,7 @@ module Cassandra.Exec paginateC, PageWithState (..), paginateWithState, + paginateWithStateC, paramsPagingState, pwsHasMore, module C, @@ -115,6 +116,29 @@ paginateWithState q p = do pure $ PageWithState b (pagingState m) _ -> throwM $ UnexpectedResponse (hrHost r) (hrResponse r) +-- | Like 'paginateWithState' but returns a conduit instead of one page. +-- +-- This can be used with 'paginateWithState' like this: +-- @ +-- main :: IO () +-- main = do +-- runConduit $ +-- paginateWithStateC getUsers +-- .| mapC doSomethingWithAPageOfUsers +-- where +-- getUsers state = paginateWithState getUsersQuery (paramsPagingState Quorum () 10000 state) +-- @ +paginateWithStateC :: forall m a. (Monad m) => (Maybe Protocol.PagingState -> m (PageWithState a)) -> ConduitT () [a] m () +paginateWithStateC getPage = do + go =<< lift (getPage Nothing) + where + go :: PageWithState a -> ConduitT () [a] m () + go page = do + unless (null page.pwsResults) $ + yield (page.pwsResults) + when (pwsHasMore page) $ + go =<< lift (getPage page.pwsState) + paramsPagingState :: Consistency -> a -> Int32 -> Maybe Protocol.PagingState -> QueryParams a paramsPagingState c p n state = QueryParams c False p (Just n) state Nothing Nothing {-# INLINE paramsPagingState #-} diff --git a/libs/cassandra-util/src/Cassandra/Util.hs b/libs/cassandra-util/src/Cassandra/Util.hs index f8b793f77db..4331da819c5 100644 --- a/libs/cassandra-util/src/Cassandra/Util.hs +++ b/libs/cassandra-util/src/Cassandra/Util.hs @@ -109,6 +109,7 @@ initCassandra settings Nothing logger = do -- | Read cassandra's writetimes https://docs.datastax.com/en/dse/5.1/cql/cql/cql_using/useWritetime.html -- as UTCTime values without any loss of precision newtype Writetime a = Writetime {writetimeToUTC :: UTCTime} + deriving (Functor) instance Cql (Writetime a) where ctype = Tagged BigIntColumn diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 63075543d4a..0749d912513 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -108,6 +108,12 @@ data GalleyAPIAccess m a where GetAllTeamFeaturesForUser :: Maybe UserId -> GalleyAPIAccess m AllTeamFeatures + GetFeatureConfigForTeam :: + ( IsFeatureConfig feature, + Typeable feature + ) => + TeamId -> + GalleyAPIAccess m (LockableFeature feature) GetVerificationCodeEnabled :: TeamId -> GalleyAPIAccess m Bool diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index e226d09bcdd..39cc61b0feb 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -80,6 +80,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamName id' -> getTeamName id' GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' GetTeamSearchVisibility id' -> getTeamSearchVisibility id' + GetFeatureConfigForTeam tid -> getFeatureConfigForTeam tid ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' GetAllTeamFeaturesForUser m_id' -> getAllTeamFeaturesForUser m_id' @@ -432,6 +433,25 @@ getTeamSearchVisibility tid = . paths ["i", "teams", toByteString' tid, "search-visibility"] . expect2xx +getFeatureConfigForTeam :: + forall feature r. + ( IsFeatureConfig feature, + Typeable feature, + Member TinyLog r, + Member Rpc r, + Member (Error ParseException) r + ) => + TeamId -> + Sem (Input Endpoint : r) (LockableFeature feature) +getFeatureConfigForTeam tid = do + debug $ remote "galley" . msg (val "Get feature config for team") + galleyRequest req >>= decodeBodyOrThrow "galley" + where + req = + method GET + . paths ["i", "teams", toByteString' tid, "features", featureNameBS @feature] + . expect2xx + getVerificationCodeEnabled :: ( Member (Error ParseException) r, Member Rpc r, diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs new file mode 100644 index 00000000000..232a61f2f42 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.IndexedUserStore where + +import Data.Id +import Database.Bloodhound.Types +import Polysemy +import Wire.UserSearch.Types + +data IndexedUserStore m a where + Upsert :: DocId -> UserDoc -> VersionControl -> IndexedUserStore m () + UpdateTeamSearchVisibilityInbound :: TeamId -> SearchVisibilityInbound -> IndexedUserStore m () + -- | Will only be applied to main ES index and not the additional one + BulkUpsert :: [(DocId, UserDoc, VersionControl)] -> IndexedUserStore m () + +makeSem ''IndexedUserStore diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs new file mode 100644 index 00000000000..5c2264dc6c4 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -0,0 +1,142 @@ +module Wire.IndexedUserStore.ElasticSearch where + +import Data.Aeson +import Data.Aeson.Key qualified as Key +import Data.ByteString.Builder +import Data.ByteString.Conversion +import Data.Credentials +import Data.Id +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Database.Bloodhound qualified as ES +import Imports +import Network.HTTP.Client +import Network.HTTP.Types +import Polysemy +import Polysemy.Error +import Wire.IndexedUserStore +import Wire.UserSearch.Types + +data ESConn = ESConn + { env :: ES.BHEnv, + credentials :: Maybe Credentials, + indexName :: ES.IndexName + } + +data IndexedUserStoreConfig = IndexedUserStoreConfig + { conn :: ESConn, + additionalConn :: Maybe ESConn + } + +data IndexedUserStoreError = IndexUpdateError ES.EsError + +interpretIndexedUserStoreES :: (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> InterpreterFor IndexedUserStore r +interpretIndexedUserStoreES cfg = + interpret $ \case + Upsert docId userDoc versioning -> upsertImpl cfg docId userDoc versioning + UpdateTeamSearchVisibilityInbound tid vis -> updateTeamSearchVisibilityInboundImpl cfg tid vis + BulkUpsert docs -> bulkUpsertImpl cfg docs + +upsertImpl :: forall r. (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> ES.DocId -> UserDoc -> ES.VersionControl -> Sem r () +upsertImpl cfg docId userDoc versioning = do + runInBothES cfg indexDoc + where + indexDoc :: ES.IndexName -> ES.BH (Sem r) () + indexDoc idx = do + r <- ES.indexDocument idx mappingName settings userDoc docId + unless (ES.isSuccess r || ES.isVersionConflict r) $ do + -- liftIO $ Prom.incCounter indexUpdateErrorCounter + res <- liftIO $ ES.parseEsResponse r + lift . throw . IndexUpdateError . either id id $ res + -- liftIO $ Prom.incCounter indexUpdateSuccessCounter + + settings = ES.defaultIndexDocumentSettings {ES.idsVersionControl = versioning} + +updateTeamSearchVisibilityInboundImpl :: forall r. (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> TeamId -> SearchVisibilityInbound -> Sem r () +updateTeamSearchVisibilityInboundImpl cfg tid vis = + runInBothES cfg updateAllDocs + where + updateAllDocs :: ES.IndexName -> ES.BH (Sem r) () + updateAllDocs idx = do + r <- ES.updateByQuery idx query (Just script) + unless (ES.isSuccess r || ES.isVersionConflict r) $ do + res <- liftIO $ ES.parseEsResponse r + lift . throw . IndexUpdateError . either id id $ res + + query :: ES.Query + query = ES.TermQuery (ES.Term "team" $ idToText tid) Nothing + + script :: ES.Script + script = ES.Script (Just (ES.ScriptLanguage "painless")) (Just (ES.ScriptInline scriptText)) Nothing Nothing + + -- Unfortunately ES disallows updating ctx._version with a "Update By Query" + scriptText = + "ctx._source." + <> Key.toText searchVisibilityInboundFieldName + <> " = '" + <> Text.decodeUtf8 (toByteString' vis) + <> "';" + +bulkUpsertImpl :: + ( Member (Embed IO) r, + Member (Error IndexedUserStoreError) r + ) => + IndexedUserStoreConfig -> + [(ES.DocId, UserDoc, ES.VersionControl)] -> + Sem r () +bulkUpsertImpl cfg docs = do + let bhe = cfg.conn.env + ES.IndexName idx = cfg.conn.indexName + ES.MappingName mpp = mappingName + (ES.Server base) = ES.bhServer bhe + authHeaders = maybe [] ((: []) . mkBasicAuthHeader) cfg.conn.credentials + req <- embed $ parseRequest (Text.unpack $ base <> "/" <> idx <> "/" <> mpp <> "/_bulk") + res <- + embed $ + httpLbs + req + { method = "POST", + requestHeaders = [(hContentType, "application/x-ndjson")] <> authHeaders, -- sic + requestBody = RequestBodyLBS (toLazyByteString (foldMap encodeActionAndData docs)) + } + (ES.bhManager bhe) + unless (ES.isSuccess res) $ do + parsedRes <- liftIO $ ES.parseEsResponse res + throw . IndexUpdateError . either id id $ parsedRes + where + encodeJSONToString :: (ToJSON a) => a -> Builder + encodeJSONToString = fromEncoding . toEncoding + + encodeActionAndData :: (ES.DocId, UserDoc, ES.VersionControl) -> Builder + encodeActionAndData (docId, userDoc, versionControl) = + encodeJSONToString (bulkIndexAction docId versionControl) + <> "\n" + <> encodeJSONToString userDoc + <> "\n" + + bulkIndexAction :: ES.DocId -> ES.VersionControl -> Value + bulkIndexAction docId versionControl = + let (versionType :: Maybe Text, version) = case versionControl of + ES.NoVersionControl -> (Nothing, Nothing) + ES.InternalVersion v -> (Nothing, Just v) + ES.ExternalGT (ES.ExternalDocVersion v) -> (Just "external", Just v) + ES.ExternalGTE (ES.ExternalDocVersion v) -> (Just "external_gte", Just v) + ES.ForceVersion (ES.ExternalDocVersion v) -> (Just "force", Just v) + in object + [ "index" + .= object + [ "_id" .= docId, + "_version_type" .= versionType, + "_version" .= version + ] + ] + +runInBothES :: (Monad m) => IndexedUserStoreConfig -> (ES.IndexName -> ES.BH m a) -> m a +runInBothES cfg f = do + x <- ES.runBH cfg.conn.env $ f cfg.conn.indexName + forM_ cfg.additionalConn $ \additional -> + ES.runBH additional.env $ f additional.indexName + pure x + +mappingName :: ES.MappingName +mappingName = ES.MappingName "user" diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs new file mode 100644 index 00000000000..a6aad6f74a1 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs @@ -0,0 +1,174 @@ +module Wire.UserSearch.Types where + +import Cassandra qualified as C +import Cassandra.Util +import Data.Aeson +import Data.Attoparsec.ByteString +import Data.ByteString.Builder +import Data.ByteString.Conversion +import Data.ByteString.Lazy +import Data.Handle +import Data.Id +import Data.Json.Util +import Data.Text.Encoding +import Database.Bloodhound.Types +import Imports +import Test.QuickCheck +import Wire.API.Team.Feature +import Wire.API.Team.Role +import Wire.API.User +import Wire.API.User.Search + +newtype IndexVersion = IndexVersion {docVersion :: DocVersion} + +mkIndexVersion :: [Maybe (Writetime x)] -> IndexVersion +mkIndexVersion writetimes = + let maxVersion = getMax . mconcat . fmap (Max . writetimeToInt64) $ catMaybes writetimes + in -- This minBound case would only get triggered when the maxVersion is <= 0 + -- or >= 9.2e+18. First case can happen when the writetimes list is empty + -- or contains a timestamp before the unix epoch, which is unlikely. + -- Second case will happen in a few billion years. It is also not really a + -- restriction in ES, Bloodhound's authors' interpretation of the the ES + -- documentation caused this limiation, otherwise `maxBound :: Int64`, + -- would be acceptable by ES. + IndexVersion . fromMaybe minBound . mkDocVersion . fromIntegral $ maxVersion + +-- | Represents an ES *document*, ie. the subset of user attributes stored in ES. +-- See also 'IndexUser'. +-- +-- If a user is not searchable, e.g. because the account got +-- suspended, all fields except for the user id are set to 'Nothing' and +-- consequently removed from the index. +data UserDoc = UserDoc + { udId :: UserId, + udTeam :: Maybe TeamId, + udName :: Maybe Name, + udNormalized :: Maybe Text, + udHandle :: Maybe Handle, + udEmail :: Maybe EmailAddress, + udColourId :: Maybe ColourId, + udAccountStatus :: Maybe AccountStatus, + udSAMLIdP :: Maybe Text, + udManagedBy :: Maybe ManagedBy, + udCreatedAt :: Maybe UTCTimeMillis, + udRole :: Maybe Role, + udSearchVisibilityInbound :: Maybe SearchVisibilityInbound, + udScimExternalId :: Maybe Text, + udSso :: Maybe Sso, + udEmailUnvalidated :: Maybe EmailAddress + } + deriving (Eq, Show) + +-- Note: Keep this compatible with the FromJSON instances +-- of 'Contact' and 'TeamContact' from 'Wire.API.User.Search +instance ToJSON UserDoc where + toJSON ud = + object + [ "id" .= udId ud, + "team" .= udTeam ud, + "name" .= udName ud, + "normalized" .= udNormalized ud, + "handle" .= udHandle ud, + "email" .= udEmail ud, + "accent_id" .= udColourId ud, + "account_status" .= udAccountStatus ud, + "saml_idp" .= udSAMLIdP ud, + "managed_by" .= udManagedBy ud, + "created_at" .= udCreatedAt ud, + "role" .= udRole ud, + searchVisibilityInboundFieldName .= udSearchVisibilityInbound ud, + "scim_external_id" .= udScimExternalId ud, + "sso" .= udSso ud, + "email_unvalidated" .= udEmailUnvalidated ud + ] + +instance FromJSON UserDoc where + parseJSON = withObject "UserDoc" $ \o -> + UserDoc + <$> o .: "id" + <*> o .:? "team" + <*> o .:? "name" + <*> o .:? "normalized" + <*> o .:? "handle" + <*> o .:? "email" + <*> o .:? "accent_id" + <*> o .:? "account_status" + <*> o .:? "saml_idp" + <*> o .:? "managed_by" + <*> o .:? "created_at" + <*> o .:? "role" + <*> o .:? searchVisibilityInboundFieldName + <*> o .:? "scim_external_id" + <*> o .:? "sso" + <*> o .:? "email_unvalidated" + +searchVisibilityInboundFieldName :: Key +searchVisibilityInboundFieldName = "search_visibility_inbound" + +-- | Outbound search restrictions configured by team admin of the searcher. This +-- value restricts the set of user that are searched. +-- +-- See 'optionallySearchWithinTeam' for the effect on full-text search. +-- +-- See 'mkTeamSearchInfo' for the business logic that defines the TeamSearchInfo +-- value. +-- +-- Search results might be affected by the inbound search restriction settings of +-- the searched user. ('SearchVisibilityInbound') +data TeamSearchInfo + = -- | Only users that are not part of any team are searched + NoTeam + | -- | Only users from the same team as the searcher are searched + TeamOnly TeamId + | -- | No search restrictions, all users are searched + AllUsers + +-- | Inbound search restrictions configured by team to-be-searched. Affects only +-- full-text search (i.e. search on the display name and the handle), not exact +-- handle search. +data SearchVisibilityInbound + = -- | The user can only be found by users from the same team + SearchableByOwnTeam + | -- | The user can by found by any user of any team + SearchableByAllTeams + deriving (Eq, Show) + +instance Arbitrary SearchVisibilityInbound where + arbitrary = elements [SearchableByOwnTeam, SearchableByAllTeams] + +instance ToByteString SearchVisibilityInbound where + builder SearchableByOwnTeam = "searchable-by-own-team" + builder SearchableByAllTeams = "searchable-by-all-teams" + +instance FromByteString SearchVisibilityInbound where + parser = + SearchableByOwnTeam + <$ string "searchable-by-own-team" + <|> SearchableByAllTeams + <$ string "searchable-by-all-teams" + +instance C.Cql SearchVisibilityInbound where + ctype = C.Tagged C.IntColumn + + toCql SearchableByOwnTeam = C.CqlInt 0 + toCql SearchableByAllTeams = C.CqlInt 1 + + fromCql (C.CqlInt 0) = pure SearchableByOwnTeam + fromCql (C.CqlInt 1) = pure SearchableByAllTeams + fromCql n = Left $ "Unexpected SearchVisibilityInbound: " ++ show n + +defaultSearchVisibilityInbound :: SearchVisibilityInbound +defaultSearchVisibilityInbound = SearchableByOwnTeam + +searchVisibilityInboundFromFeatureStatus :: FeatureStatus -> SearchVisibilityInbound +searchVisibilityInboundFromFeatureStatus FeatureStatusDisabled = SearchableByOwnTeam +searchVisibilityInboundFromFeatureStatus FeatureStatusEnabled = SearchableByAllTeams + +instance ToJSON SearchVisibilityInbound where + toJSON = String . decodeUtf8 . toStrict . toLazyByteString . builder + +instance FromJSON SearchVisibilityInbound where + parseJSON = withText "SearchVisibilityInbound" $ \str -> + case runParser (parser @SearchVisibilityInbound) (encodeUtf8 str) of + Left err -> fail err + Right result -> pure result diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs new file mode 100644 index 00000000000..d2ac19ccedc --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.UserSearchSubsystem where + +import Data.Domain +import Data.Id +import Data.Qualified +import Data.Range +import Imports +import Polysemy +import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) +import Wire.API.Team.Feature +import Wire.API.User.Search + +data BrowseTeamFilters = BrowseTeamFilters + { teamId :: TeamId, + mQuery :: Maybe Text, + mRoleFilter :: Maybe RoleFilter, + mSortBy :: Maybe TeamUserSearchSortBy, + mSortOrder :: Maybe TeamUserSearchSortOrder + } + +data UserSearchSubsystem m a where + SyncUser :: UserId -> UserSearchSubsystem m () + UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSearchSubsystem m () + SearchUser :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m [Contact] + BrowseTeam :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> UserSearchSubsystem m [TeamContact] + +makeSem ''UserSearchSubsystem + +-- | This function exists because there are a lot query params and they cannot all become 'BrowseTeamFilters' automatically +browseTeamHandler :: + (Member UserSearchSubsystem r) => + UserId -> + TeamId -> + Maybe Text -> + Maybe RoleFilter -> + Maybe TeamUserSearchSortBy -> + Maybe TeamUserSearchSortOrder -> + Maybe (Range 1 500 Int32) -> + Maybe PagingState -> + Sem r [TeamContact] +browseTeamHandler uid tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder mMaxResults mPagingState = do + let browseTeamFilters = BrowseTeamFilters tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder + browseTeam uid browseTeamFilters mMaxResults mPagingState + +-- | Bulk operations, must not be used from any web handler +data UserSearchSubsystemBulk m a where + -- | Only changes data if it is not updated since last update, use when users + -- need to be synced because of an outage, or migrating to a new ES instance. + SyncAllUsers :: UserSearchSubsystemBulk m () + -- | Overwrite all users in the ES index, use it when trying to fix some + -- inconsistency or while introducing a new field in the mapping. + ForceSyncAllUsers :: UserSearchSubsystemBulk m () + +makeSem ''UserSearchSubsystemBulk diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs new file mode 100644 index 00000000000..010b3806119 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -0,0 +1,130 @@ +module Wire.UserSearchSubsystem.Interpreter where + +import Cassandra.Exec (paginateWithStateC) +import Conduit (ConduitT, runConduit, (.|)) +import Data.Conduit.Combinators qualified as Conduit +import Data.Domain +import Data.Id +import Data.Map qualified as Map +import Data.Qualified +import Data.Range +import Data.Set qualified as Set +import Database.Bloodhound.Types qualified as ES +import Imports +import Polysemy +import Polysemy.TinyLog +import System.Logger.Message qualified as Log +import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) +import Wire.API.Team.Feature +import Wire.API.User.Search +import Wire.GalleyAPIAccess +import Wire.IndexedUserStore (IndexedUserStore) +import Wire.IndexedUserStore qualified as IndexedUserStore +import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) +import Wire.UserSearch.Types +import Wire.UserSearchSubsystem +import Wire.UserStore +import Wire.UserStore.IndexUser + +interpretUserSearchSubsystem :: + ( Member UserStore r, + Member GalleyAPIAccess r, + Member IndexedUserStore r + ) => + InterpreterFor UserSearchSubsystem r +interpretUserSearchSubsystem = interpret \case + SyncUser uid -> syncUserImpl uid + UpdateTeamSearchVisibilityInbound status -> updateTeamSearchVisibilityInboundImpl status + SearchUser luid query mDomain mMaxResults -> searchUserImpl luid query mDomain mMaxResults + BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> do + browseTeamImpl uid browseTeamFilters mMaxResults mPagingState + +interpretUserSearchSubsystemBulk :: + ( Member TinyLog r, + Member UserStore r, + Member (Concurrency Unsafe) r, + Member GalleyAPIAccess r, + Member IndexedUserStore r + ) => + InterpreterFor UserSearchSubsystemBulk r +interpretUserSearchSubsystemBulk = interpret \case + SyncAllUsers -> syncAllUsersImpl (ES.ExternalGT) + ForceSyncAllUsers -> syncAllUsersImpl (ES.ExternalGTE) + +syncUserImpl :: + forall r. + ( Member UserStore r, + Member GalleyAPIAccess r, + Member IndexedUserStore r + ) => + UserId -> + Sem r () +syncUserImpl uid = + getIndexUser uid + >>= maybe delete upsert + where + delete :: Sem r () + delete = do + IndexedUserStore.upsert (docId uid) (emptyUserDoc uid) ES.NoVersionControl + + upsert :: IndexUser -> Sem r () + upsert indexUser = do + vis <- + maybe + (pure defaultSearchVisibilityInbound) + teamSearchVisibilityInbound + indexUser.teamId + let userDoc = indexUserRowToDoc vis indexUser + version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserRowToVersion indexUser + IndexedUserStore.upsert (docId uid) userDoc version + +syncAllUsersImpl :: + forall r. + ( Member UserStore r, + Member TinyLog r, + Member (Concurrency 'Unsafe) r, + Member GalleyAPIAccess r, + Member IndexedUserStore r + ) => + (ES.ExternalDocVersion -> ES.VersionControl) -> + Sem r () +syncAllUsersImpl mkVersion = + runConduit $ + paginateWithStateC getIndexUsersPaginated + .| logPage + .| mkUserDocs + .| Conduit.mapM_ IndexedUserStore.bulkUpsert + where + logPage :: ConduitT [IndexUser] [IndexUser] (Sem r) () + logPage = Conduit.iterM $ \page -> do + info $ + Log.field "size" (length page) + . Log.msg (Log.val "Reindex: processing C* page") + + mkUserDocs :: ConduitT [IndexUser] [(ES.DocId, UserDoc, ES.VersionControl)] (Sem r) () + mkUserDocs = Conduit.mapM $ \page -> do + visMap <- fmap Map.fromList . unsafePooledForConcurrentlyN 16 (Set.fromList $ mapMaybe (.teamId) page) $ \t -> + (t,) <$> teamSearchVisibilityInbound t + let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ flip Map.lookup visMap =<< indexUser.teamId + mkUserDoc indexUser = indexUserRowToDoc (vis indexUser) indexUser + mkDocVersion = mkVersion . ES.ExternalDocVersion . docVersion . indexUserRowToVersion + pure $ map (\u -> (docId u.userId, mkUserDoc u, mkDocVersion u)) page + +updateTeamSearchVisibilityInboundImpl :: (Member IndexedUserStore r) => TeamStatus SearchVisibilityInboundConfig -> Sem r () +updateTeamSearchVisibilityInboundImpl teamStatus = + IndexedUserStore.updateTeamSearchVisibilityInbound teamStatus.team $ + searchVisibilityInboundFromFeatureStatus teamStatus.status + +searchUserImpl :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> Sem r [Contact] +searchUserImpl = undefined + +browseTeamImpl :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> Sem r [TeamContact] +browseTeamImpl = undefined + +docId :: UserId -> ES.DocId +docId uid = ES.DocId (idToText uid) + +teamSearchVisibilityInbound :: (Member GalleyAPIAccess r) => TeamId -> Sem r SearchVisibilityInbound +teamSearchVisibilityInbound tid = + searchVisibilityInboundFromFeatureStatus . (.status) + <$> getFeatureConfigForTeam @_ @SearchVisibilityInboundConfig tid diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 3544ec5b35b..46e274ffacb 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -1,8 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} module Wire.UserStore where +import Cassandra (PageWithState (..), PagingState) import Data.Default import Data.Handle import Data.Id @@ -12,6 +12,7 @@ import Polysemy.Error import Wire.API.User import Wire.Arbitrary import Wire.StoredUser +import Wire.UserStore.IndexUser -- | Update of any "simple" attributes (ones that do not involve locking, like handle, or -- validation protocols, like email). @@ -47,6 +48,8 @@ data StoredUserUpdateError = StoredUserUpdateHandleExists -- database logic; validate handle is application logic.) data UserStore m a where GetUser :: UserId -> UserStore m (Maybe StoredUser) + GetIndexUser :: UserId -> UserStore m (Maybe IndexUser) + GetIndexUsersPaginated :: Maybe PagingState -> UserStore m (PageWithState IndexUser) UpdateUser :: UserId -> StoredUserUpdate -> UserStore m () UpdateUserHandleEither :: UserId -> StoredUserHandleUpdate -> UserStore m (Either StoredUserUpdateError ()) DeleteUser :: User -> UserStore m () diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index d835a265f7b..106bbfffa4c 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -1,6 +1,7 @@ module Wire.UserStore.Cassandra (interpretUserStoreCassandra) where import Cassandra +import Cassandra.Exec (prepared) import Data.Handle import Data.Id import Database.CQL.Protocol @@ -11,6 +12,7 @@ import Polysemy.Error import Wire.API.User hiding (DeleteUser) import Wire.StoredUser import Wire.UserStore +import Wire.UserStore.IndexUser hiding (userId) import Wire.UserStore.Unique interpretUserStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor UserStore r @@ -18,6 +20,8 @@ interpretUserStoreCassandra casClient = interpret $ runEmbedded (runClient casClient) . embed . \case GetUser uid -> getUserImpl uid + GetIndexUser uid -> getIndexUserImpl uid + GetIndexUsersPaginated mPagingState -> getIndexUserPaginatedImpl mPagingState UpdateUser uid update -> updateUserImpl uid update UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update DeleteUser user -> deleteUserImpl user @@ -32,6 +36,37 @@ getUserImpl uid = do mUserTuple <- retry x1 $ query1 selectUser (params LocalQuorum (Identity uid)) pure $ asRecord <$> mUserTuple +getIndexUserImpl :: UserId -> Client (Maybe IndexUser) +getIndexUserImpl u = do + mIndexUserTuple <- retry x1 $ query1 cql (params LocalQuorum (Identity u)) + pure $ asRecord <$> mIndexUserTuple + where + cql :: PrepQuery R (Identity UserId) (TupleType IndexUser) + cql = prepared . QueryString $ getIndexUserBaseQuery <> " WHERE id = ?" + +getIndexUserPaginatedImpl :: Maybe PagingState -> Client (PageWithState IndexUser) +getIndexUserPaginatedImpl mPagingState = + asRecord <$$> paginateWithState cql (paramsPagingState LocalQuorum () 10000 mPagingState) + where + cql :: PrepQuery R () (TupleType IndexUser) + cql = prepared $ QueryString getIndexUserBaseQuery + +getIndexUserBaseQuery :: LText +getIndexUserBaseQuery = + "SELECT \ + \id, team, \ + \name, writetime(name), \ + \status, writetime(status), \ + \handle, writetime(handle), \ + \email, writetime(email), \ + \accent_id, writetime(accent_id), \ + \activated, writetime(activated), \ + \service, writetime(service), \ + \managed_by, writetime(managed_by), \ + \sso_id, writetime(sso_id), \ + \email_unvalidated, writetime(email_unvalidated) \ + \FROM user" + updateUserImpl :: UserId -> StoredUserUpdate -> Client () updateUserImpl uid update = retry x5 $ batch do diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs new file mode 100644 index 00000000000..1809ca3ca89 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE RecordWildCards #-} + +module Wire.UserStore.IndexUser where + +import Cassandra.Util +import Data.ByteString.Builder +import Data.ByteString.Lazy qualified as LBS +import Data.Handle +import Data.Id +import Data.Json.Util +import Data.Text.Encoding qualified as Text +import Data.Text.Encoding.Error qualified as Text +import Data.Text.ICU.Translit +import Database.CQL.Protocol +import Imports +import SAML2.WebSSO qualified as SAML +import URI.ByteString +import Wire.API.User hiding (userId) +import Wire.API.User.Search +import Wire.UserSearch.Types + +type Activated = Bool + +data WithWritetime a = WithWriteTime {value :: a, writetime :: Writetime a} + +data IndexUser = IndexUser + { userId :: UserId, + teamId :: Maybe TeamId, + name :: WithWritetime Name, + accountStatus :: Maybe (WithWritetime AccountStatus), + handle :: Maybe (WithWritetime Handle), + email :: Maybe (WithWritetime EmailAddress), + colourId :: WithWritetime ColourId, + activated :: WithWritetime Activated, + serviceId :: Maybe (WithWritetime ServiceId), + managedBy :: Maybe (WithWritetime ManagedBy), + ssoId :: Maybe (WithWritetime UserSSOId), + unverifiedEmail :: Maybe (WithWritetime EmailAddress) + } + +type instance + TupleType IndexUser = + ( UserId, + Maybe TeamId, + Name, + Writetime Name, + Maybe AccountStatus, + Maybe (Writetime AccountStatus), + Maybe Handle, + Maybe (Writetime Handle), + Maybe Email, + Maybe (Writetime Email), + ColourId, + Writetime ColourId, + Activated, + Writetime Activated, + Maybe ServiceId, + Maybe (Writetime ServiceId), + Maybe ManagedBy, + Maybe (Writetime ManagedBy), + Maybe UserSSOId, + Maybe (Writetime UserSSOId), + Maybe Email, + Maybe (Writetime Email) + ) + +{- ORMOLU_DISABLE -} + +instance Record IndexUser where + asTuple (IndexUser {..}) = + ( userId, teamId, + name.value, name.writetime, + value <$> accountStatus, writetime <$> accountStatus, + value <$> handle, writetime <$> handle, + value <$> email, writetime <$> email, + colourId.value, colourId.writetime, + activated.value, activated.writetime, + value <$> serviceId, writetime <$> serviceId, + value <$> managedBy, writetime <$> managedBy, + value <$> ssoId, writetime <$> ssoId, + value <$> unverifiedEmail, writetime <$> unverifiedEmail + ) + + asRecord + ( u, mteam, + name, tName, + status, tStatus, + handle, tHandle, + email, tEmail, + colour, tColour, + activated, tActivated, + service, tService, + managedBy, tManagedBy, + ssoId, tSsoId, + emailUnvalidated, tEmailUnvalidated + ) = IndexUser { + userId = u, + teamId = mteam, + name = WithWriteTime name tName, + accountStatus = WithWriteTime <$> status <*> tStatus, + handle = WithWriteTime <$> handle <*> tHandle, + email = WithWriteTime <$> email <*> tEmail, + colourId = WithWriteTime colour tColour, + activated = WithWriteTime activated tActivated, + serviceId = WithWriteTime <$> service <*> tService, + managedBy = WithWriteTime <$> managedBy <*> tManagedBy, + ssoId = WithWriteTime <$> ssoId <*> tSsoId, + unverifiedEmail = WithWriteTime <$> emailUnvalidated <*> tEmailUnvalidated + } +{- ORMOLU_ENABLE -} + +indexUserRowToVersion :: IndexUser -> IndexVersion +indexUserRowToVersion IndexUser {..} = + mkIndexVersion + [ const () <$$> Just name.writetime, + const () <$$> fmap writetime accountStatus, + const () <$$> fmap writetime handle, + const () <$$> fmap writetime email, + const () <$$> Just colourId.writetime, + const () <$$> Just activated.writetime, + const () <$$> fmap writetime serviceId, + const () <$$> fmap writetime managedBy, + const () <$$> fmap writetime ssoId, + const () <$$> fmap writetime unverifiedEmail + ] + +indexUserRowToDoc :: SearchVisibilityInbound -> IndexUser -> UserDoc +indexUserRowToDoc searchVisInbound IndexUser {..} = + if shouldIndex + then + UserDoc + { udEmailUnvalidated = value <$> unverifiedEmail, + udSso = sso . value =<< ssoId, + udScimExternalId = join $ scimExternalId <$> (value <$> managedBy) <*> (value <$> ssoId), + udSearchVisibilityInbound = Just searchVisInbound, + udRole = Nothing, -- TODO: This looks weird, why do we have this? + udCreatedAt = Just . toUTCTimeMillis $ writetimeToUTC activated.writetime, + udManagedBy = value <$> managedBy, + udSAMLIdP = idpUrl . value =<< ssoId, + udAccountStatus = value <$> accountStatus, + udColourId = Just colourId.value, + udEmail = value <$> email, + udHandle = value <$> handle, + udNormalized = Just $ normalized name.value.fromName, + udName = Just name.value, + udTeam = teamId, + udId = userId + } + else -- We insert a tombstone-style user here, as it's easier than + -- deleting the old one. It's mostly empty, but having the status here + -- might be useful in the future. + emptyUserDoc userId + where + shouldIndex = + ( case value <$> accountStatus of + Nothing -> True + Just Active -> True + Just Suspended -> True + Just Deleted -> False + Just Ephemeral -> False + Just PendingInvitation -> False + ) + && activated.value -- FUTUREWORK: how is this adding to the first case? + && isNothing serviceId + + idpUrl :: UserSSOId -> Maybe Text + idpUrl (UserSSOId (SAML.UserRef (SAML.Issuer uri) _subject)) = + Just $ fromUri uri + idpUrl (UserScimExternalId _) = Nothing + + fromUri :: URI -> Text + fromUri = + Text.decodeUtf8With Text.lenientDecode + . LBS.toStrict + . toLazyByteString + . serializeURIRef + + sso :: UserSSOId -> Maybe Sso + sso userSsoId = do + (issuer, nameid) <- ssoIssuerAndNameId userSsoId + pure $ Sso {ssoIssuer = issuer, ssoNameId = nameid} + + -- Transliteration could also be done by ElasticSearch (ICU plugin), but this would + -- require a data migration. + normalized :: Text -> Text + normalized = transliterate (trans "Any-Latin; Latin-ASCII; Lower") + +emptyUserDoc :: UserId -> UserDoc +emptyUserDoc uid = + UserDoc + { udEmailUnvalidated = Nothing, + udSso = Nothing, + udScimExternalId = Nothing, + udSearchVisibilityInbound = Nothing, + udRole = Nothing, + udCreatedAt = Nothing, + udManagedBy = Nothing, + udSAMLIdP = Nothing, + udAccountStatus = Nothing, + udColourId = Nothing, + udEmail = Nothing, + udHandle = Nothing, + udNormalized = Nothing, + udName = Nothing, + udTeam = Nothing, + udId = uid + } diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 563b91f4bd1..c94daea1d75 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -31,6 +31,8 @@ inMemoryUserStoreInterpreter = interpret $ \case . maybe Imports.id setStoredUserSupportedProtocols update.supportedProtocols $ u else u + GetIndexUser _uid -> undefined + GetIndexUsersPaginated _pagingState -> undefined UpdateUserHandleEither uid hUpdate -> runError $ modifyLocalUsers (traverse doUpdate) where doUpdate :: StoredUser -> Sem (Error StoredUserUpdateError : r) StoredUser diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index e2763335c9f..e155337e1d6 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -91,6 +91,8 @@ library Wire.GalleyAPIAccess.Rpc Wire.GundeckAPIAccess Wire.HashPassword + Wire.IndexedUserStore + Wire.IndexedUserStore.ElasticSearch Wire.InternalEvent Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter @@ -109,8 +111,12 @@ library Wire.StoredUser Wire.UserKeyStore Wire.UserKeyStore.Cassandra + Wire.UserSearch.Types + Wire.UserSearchSubsystem + Wire.UserSearchSubsystem.Interpreter Wire.UserStore Wire.UserStore.Cassandra + Wire.UserStore.IndexUser Wire.UserStore.Unique Wire.UserSubsystem Wire.UserSubsystem.Error @@ -130,12 +136,15 @@ library , amazonka-core , amazonka-ses , async + , attoparsec , base , base16-bytestring , bilge + , bloodhound , bytestring , bytestring-conversion , cassandra-util + , conduit , containers , cql , crypton @@ -171,11 +180,14 @@ library , resource-pool , resourcet , retry + , saml2-web-sso + , schema-profunctor , servant , servant-client-core , stomp-queue , template , text + , text-icu-translit , time , time-out , time-units @@ -185,6 +197,7 @@ library , types-common , unliftio , unordered-containers + , uri-bytestring , uuid , wai-utilities , wire-api diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 3f71d1eff87..fa238ed829b 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -200,7 +200,6 @@ library Brig.User.Auth.Cookie.Limit Brig.User.EJPD Brig.User.Search.Index - Brig.User.Search.Index.Types Brig.User.Search.SearchIndex Brig.User.Search.TeamSize Brig.User.Search.TeamUserSearch @@ -296,7 +295,6 @@ library , resourcet >=1.1 , retry >=0.7 , safe-exceptions >=0.1 - , saml2-web-sso , schema-profunctor , scientific >=0.3.4 , servant @@ -311,7 +309,6 @@ library , template >=0.2 , template-haskell , text >=0.11 - , text-icu-translit >=0.1 , time >=1.1 , time-out , time-units diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index 24d8ec75016..cd90cdb9c22 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -19,9 +19,7 @@ -- with this program. If not, see . module Brig.User.Search.Index - ( mappingName, - boolQuery, - _TextId, + ( boolQuery, -- * Monad IndexEnv (..), @@ -29,21 +27,14 @@ module Brig.User.Search.Index runIndexIO, MonadIndexIO (..), - -- * Updates - reindex, - updateSearchVisibilityInbound, - -- * Administrative createIndex, createIndexIfNotPresent, resetIndex, - reindexAll, - reindexAllIfSameOrNewer, refreshIndex, updateMapping, -- * Re-exports - module Types, ES.IndexSettings (..), ES.IndexName (..), ) @@ -57,50 +48,31 @@ import Bilge.Request qualified as RPC (empty, host, method, port) import Bilge.Response (responseJsonThrow) import Bilge.Retry (rpcHandlers) import Brig.Index.Types (CreateIndexSettings (..)) -import Brig.Types.Search (SearchVisibilityInbound, defaultSearchVisibilityInbound, searchVisibilityInboundFromFeatureStatus) -import Brig.User.Search.Index.Types as Types -import Cassandra.CQL qualified as C -import Cassandra.Exec qualified as C -import Cassandra.Util import Control.Lens hiding ((#), (.=)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM, try) import Control.Monad.Except import Control.Retry (RetryPolicy, exponentialBackoff, limitRetries, recovering) import Data.Aeson as Aeson -import Data.Aeson.Encoding -import Data.Aeson.Lens -import Data.ByteString (toStrict) -import Data.ByteString.Builder (Builder, toLazyByteString) -import Data.ByteString.Conversion (toByteString') -import Data.ByteString.Conversion qualified as Bytes import Data.ByteString.Lazy qualified as BL import Data.Credentials -import Data.Handle (Handle) import Data.Id import Data.Map qualified as Map import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding -import Data.Text.Encoding.Error import Data.Text.Lazy qualified as LT -import Data.Text.Lens hiding (text) -import Data.UUID qualified as UUID import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) import Network.HTTP.Client hiding (host, path, port) -import Network.HTTP.Types (StdMethod (POST), hContentType, statusCode) +import Network.HTTP.Types (StdMethod (POST), statusCode) import Prometheus (MonadMonitor) import Prometheus qualified as Prom -import SAML2.WebSSO.Types qualified as SAML import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..), field, info, msg, val, (+++), (~~)) -import URI.ByteString (URI, serializeURIRef) import Util.Options (Endpoint, host, port) import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Feature (SearchVisibilityInboundConfig, featureNameBS) -import Wire.API.User -import Wire.API.User qualified as User -import Wire.API.User.Search (Sso (..)) +import Wire.UserSearch.Types (searchVisibilityInboundFieldName) -------------------------------------------------------------------------------- -- IndexIO Monad @@ -158,141 +130,6 @@ instance MonadHttp IndexIO where manager <- asks idxRpcHttpManager liftIO $ withResponse req manager handler -withDefaultESUrl :: (MonadIndexIO m) => ES.BH m a -> m a -withDefaultESUrl action = do - bhEnv <- liftIndexIO $ asks idxElastic - ES.runBH bhEnv action - --- | When the additional URL is not provided, uses the default url. -withAdditionalESUrl :: (MonadIndexIO m) => ES.BH m a -> m a -withAdditionalESUrl action = do - mAdditionalBHEnv <- liftIndexIO $ asks idxAdditionalElastic - defaultBHEnv <- liftIndexIO $ asks idxElastic - ES.runBH (fromMaybe defaultBHEnv mAdditionalBHEnv) action - --------------------------------------------------------------------------------- --- Updates - -reindex :: (MonadLogger m, MonadIndexIO m, C.MonadClient m) => UserId -> m () -reindex u = do - ixu <- lookupIndexUser u - updateIndex (maybe (IndexDeleteUser u) (IndexUpdateUser IndexUpdateIfNewerVersion) ixu) - -updateIndex :: (MonadIndexIO m) => IndexUpdate -> m () -updateIndex (IndexUpdateUser updateType iu) = liftIndexIO $ do - Prom.incCounter indexUpdateCounter - info $ - field "user" (Bytes.toByteString (view iuUserId iu)) - . msg (val "Indexing user") - idx <- asks idxName - withDefaultESUrl $ indexDoc idx - withAdditionalESUrl $ traverse_ indexDoc =<< asks idxAdditionalName - where - indexDoc :: (MonadIndexIO m, MonadThrow m) => ES.IndexName -> ES.BH m () - indexDoc idx = do - r <- ES.indexDocument idx mappingName versioning (indexToDoc iu) docId - unless (ES.isSuccess r || ES.isVersionConflict r) $ do - liftIO $ Prom.incCounter indexUpdateErrorCounter - ES.parseEsResponse r >>= throwM . IndexUpdateError . either id id - liftIO $ Prom.incCounter indexUpdateSuccessCounter - versioning = - ES.defaultIndexDocumentSettings - { ES.idsVersionControl = indexUpdateToVersionControl updateType (ES.ExternalDocVersion (docVersion (_iuVersion iu))) - } - docId = ES.DocId (view (iuUserId . re _TextId) iu) -updateIndex (IndexUpdateUsers updateType ius) = liftIndexIO $ do - Prom.incCounter indexBulkUpdateCounter - info $ - field "num_users" (length ius) - . msg (val "Bulk indexing users") - -- Sadly, 'bloodhound' is not aware of the versioning capabilities of ES' - -- bulk API, thus we need to stitch everything together by hand. - bhe <- ES.getBHEnv - ES.IndexName idx <- asks idxName - let (ES.MappingName mpp) = mappingName - let (ES.Server base) = ES.bhServer bhe - req <- parseRequest (view unpacked $ base <> "/" <> idx <> "/" <> mpp <> "/_bulk") - authHeaders <- mkAuthHeaders - res <- - liftIO $ - httpLbs - req - { method = "POST", - requestHeaders = [(hContentType, "application/x-ndjson")] <> authHeaders, -- sic - requestBody = RequestBodyLBS (toLazyByteString (foldMap bulkEncode ius)) - } - (ES.bhManager bhe) - unless (ES.isSuccess res) $ do - Prom.incCounter indexBulkUpdateErrorCounter - ES.parseEsResponse res >>= throwM . IndexUpdateError . either id id - Prom.incCounter indexBulkUpdateSuccessCounter - for_ (statuses res) $ \(s, f) -> - Prom.withLabel indexBulkUpdateResponseCounter (Text.pack $ show s) $ (void . flip Prom.addCounter (fromIntegral f)) - where - mkAuthHeaders = do - creds <- asks idxCredentials - pure $ maybe [] ((: []) . mkBasicAuthHeader) creds - - encodeJSONToString :: (ToJSON a) => a -> Builder - encodeJSONToString = fromEncoding . toEncoding - bulkEncode iu = - bulkMeta (view (iuUserId . re _TextId) iu) (docVersion (_iuVersion iu)) - <> "\n" - <> encodeJSONToString (indexToDoc iu) - <> "\n" - bulkMeta :: Text -> ES.DocVersion -> Builder - bulkMeta docId v = - fromEncoding . pairs . pair "index" . pairs $ - "_id" .= docId - <> "_version" .= v - -- "external_gt or external_gte" - <> "_version_type" .= indexUpdateToVersionControlText updateType - statuses :: ES.Reply -> [(Int, Int)] -- [(Status, Int)] - statuses = - Map.toList - . Map.fromListWith (+) - . flip zip [1, 1 ..] - . toListOf (key "items" . values . key "index" . key "status" . _Integral) - . responseBody -updateIndex (IndexDeleteUser u) = liftIndexIO $ do - Prom.incCounter indexDeleteCounter - info $ - field "user" (Bytes.toByteString u) - . msg (val "(Soft) deleting user from index") - idx <- asks idxName - r <- ES.getDocument idx mappingName (ES.DocId (review _TextId u)) - case statusCode (responseStatus r) of - 200 -> case preview (key "_version" . _Integer) (responseBody r) of - Nothing -> throwM $ ES.EsProtocolException "'version' not found" (responseBody r) - Just v -> updateIndex . IndexUpdateUser IndexUpdateIfNewerVersion . mkIndexUser u =<< mkIndexVersion (v + 1) - 404 -> pure () - _ -> ES.parseEsResponse r >>= throwM . IndexUpdateError . either id id - -updateSearchVisibilityInbound :: (MonadIndexIO m) => Multi.TeamStatus SearchVisibilityInboundConfig -> m () -updateSearchVisibilityInbound status = liftIndexIO $ do - withDefaultESUrl . updateAllDocs =<< asks idxName - withAdditionalESUrl $ traverse_ updateAllDocs =<< asks idxAdditionalName - where - updateAllDocs :: (MonadIndexIO m, MonadThrow m) => ES.IndexName -> ES.BH m () - updateAllDocs idx = do - r <- ES.updateByQuery idx query (Just script) - unless (ES.isSuccess r || ES.isVersionConflict r) $ do - ES.parseEsResponse r >>= throwM . IndexUpdateError . either id id - - query :: ES.Query - query = ES.TermQuery (ES.Term "team" $ idToText (Multi.team status)) Nothing - - script :: ES.Script - script = ES.Script (Just (ES.ScriptLanguage "painless")) (Just (ES.ScriptInline scriptText)) Nothing Nothing - - -- Unfortunately ES disallows updating ctx._version with a "Update By Query" - scriptText = - "ctx._source." - <> searchVisibilityInboundFieldName - <> " = '" - <> decodeUtf8 (toByteString' (searchVisibilityInboundFromFeatureStatus (Multi.status status))) - <> "';" - -------------------------------------------------------------------------------- -- Administrative @@ -368,6 +205,14 @@ analysisSettings = ] in ES.Analysis analyzerDef mempty filterDef mempty +data IndexError + = IndexUpdateError ES.EsError + | IndexLookupError ES.EsError + | IndexError Text + deriving (Show) + +instance Exception IndexError + updateMapping :: (MonadIndexIO m) => m () updateMapping = liftIndexIO $ do idx <- asks idxName @@ -395,44 +240,9 @@ resetIndex ciSettings = liftIndexIO $ do then createIndex ciSettings else throwM (IndexError "Index deletion failed.") -reindexAllIfSameOrNewer :: (MonadLogger m, MonadIndexIO m, C.MonadClient m) => m () -reindexAllIfSameOrNewer = reindexAllWith IndexUpdateIfSameOrNewerVersion - -reindexAll :: (MonadLogger m, MonadIndexIO m, C.MonadClient m) => m () -reindexAll = reindexAllWith IndexUpdateIfNewerVersion - -reindexAllWith :: (MonadLogger m, MonadIndexIO m, C.MonadClient m) => IndexDocUpdateType -> m () -reindexAllWith updateType = do - idx <- liftIndexIO $ asks idxName - C.liftClient (scanForIndex 1000) >>= loop idx - where - loop idx page = do - info $ - field "size" (length (C.result page)) - . msg (val "Reindex: processing C* page") - unless (null (C.result page)) $ do - let teamsInPage = mapMaybe teamInReindexRow (C.result page) - lookupFn <- liftIndexIO $ getSearchVisibilityInboundMulti teamsInPage - let reindexRow row = - let sv = maybe defaultSearchVisibilityInbound lookupFn (teamInReindexRow row) - in reindexRowToIndexUser row sv - indexUsers <- mapM reindexRow (C.result page) - updateIndex (IndexUpdateUsers updateType indexUsers) - when (C.hasMore page) $ - C.liftClient (C.nextPage page) >>= loop idx - -------------------------------------------------------------------------------- -- Internal --- This is useful and necessary due to the lack of expressiveness in the bulk API -indexUpdateToVersionControlText :: IndexDocUpdateType -> Text -indexUpdateToVersionControlText IndexUpdateIfNewerVersion = "external_gt" -indexUpdateToVersionControlText IndexUpdateIfSameOrNewerVersion = "external_gte" - -indexUpdateToVersionControl :: IndexDocUpdateType -> (ES.ExternalDocVersion -> ES.VersionControl) -indexUpdateToVersionControl IndexUpdateIfNewerVersion = ES.ExternalGT -indexUpdateToVersionControl IndexUpdateIfSameOrNewerVersion = ES.ExternalGTE - traceES :: (MonadIndexIO m) => ByteString -> IndexIO ES.Reply -> m ES.Reply traceES descr act = liftIndexIO $ do info (msg descr) @@ -587,7 +397,7 @@ indexMapping = mpAnalyzer = Nothing, mpFields = mempty }, - (fromString . T.unpack $ searchVisibilityInboundFieldName) + searchVisibilityInboundFieldName .= MappingProperty { mpType = MPKeyword, mpStore = False, @@ -681,278 +491,6 @@ instance ToJSON MappingField where boolQuery :: ES.BoolQuery boolQuery = ES.mkBoolQuery [] [] [] [] -_TextId :: Prism' Text (Id a) -_TextId = prism' (UUID.toText . toUUID) (fmap Id . UUID.fromText) - -mappingName :: ES.MappingName -mappingName = ES.MappingName "user" - -lookupIndexUser :: - (MonadIndexIO m, C.MonadClient m) => - UserId -> - m (Maybe IndexUser) -lookupIndexUser = lookupForIndex - -lookupForIndex :: (C.MonadClient m, MonadIndexIO m) => UserId -> m (Maybe IndexUser) -lookupForIndex u = do - mrow <- C.retry C.x1 (C.query1 cql (C.params C.LocalQuorum (Identity u))) - for mrow $ \row -> do - let mteam = teamInReindexRow row - searchVis <- liftIndexIO $ getSearchVisibilityInbound mteam - reindexRowToIndexUser row searchVis - where - cql :: C.PrepQuery C.R (Identity UserId) ReindexRow - cql = - "SELECT \ - \id, \ - \team, \ - \name, \ - \writetime(name), \ - \status, \ - \writetime(status), \ - \handle, \ - \writetime(handle), \ - \email, \ - \writetime(email), \ - \accent_id, \ - \writetime(accent_id), \ - \activated, \ - \writetime(activated), \ - \service, \ - \writetime(service), \ - \managed_by, \ - \writetime(managed_by), \ - \sso_id, \ - \writetime(sso_id), \ - \email_unvalidated, \ - \writetime(email_unvalidated) \ - \FROM user \ - \WHERE id = ?" - -getSearchVisibilityInbound :: - Maybe TeamId -> - IndexIO SearchVisibilityInbound -getSearchVisibilityInbound Nothing = pure defaultSearchVisibilityInbound -getSearchVisibilityInbound (Just tid) = do - searchVisibilityInboundFromStatus <$> getTeamSearchVisibilityInbound tid - -getSearchVisibilityInboundMulti :: [TeamId] -> IndexIO (TeamId -> SearchVisibilityInbound) -getSearchVisibilityInboundMulti tids = do - Multi.TeamFeatureNoConfigMultiResponse teamsStatuses <- getTeamSearchVisibilityInboundMulti tids - let lookupMap = Map.fromList (teamsStatuses <&> \x -> (Multi.team x, x)) - pure $ \tid -> - searchVisibilityInboundFromStatus (tid `Map.lookup` lookupMap) - -searchVisibilityInboundFromStatus :: Maybe (Multi.TeamStatus SearchVisibilityInboundConfig) -> SearchVisibilityInbound -searchVisibilityInboundFromStatus = \case - Nothing -> defaultSearchVisibilityInbound - Just tvi -> searchVisibilityInboundFromFeatureStatus . Multi.status $ tvi - -scanForIndex :: Int32 -> C.Client (C.Page ReindexRow) -scanForIndex num = do - C.paginate cql (C.paramsP C.One () (num + 1)) - where - cql :: C.PrepQuery C.R () ReindexRow - cql = - "SELECT \ - \id, \ - \team, \ - \name, \ - \writetime(name), \ - \status, \ - \writetime(status), \ - \handle, \ - \writetime(handle), \ - \email, \ - \writetime(email), \ - \accent_id, \ - \writetime(accent_id), \ - \activated, \ - \writetime(activated), \ - \service, \ - \writetime(service), \ - \managed_by, \ - \writetime(managed_by), \ - \sso_id, \ - \writetime(sso_id), \ - \email_unvalidated, \ - \writetime(email_unvalidated) \ - \FROM user" - -type Activated = Bool - -type ReindexRow = - ( UserId, - Maybe TeamId, - Name, - Writetime Name, - Maybe AccountStatus, - Maybe (Writetime AccountStatus), - Maybe Handle, - Maybe (Writetime Handle), - Maybe EmailAddress, - Maybe (Writetime EmailAddress), - ColourId, - Writetime ColourId, - Activated, - Writetime Activated, - Maybe ServiceId, - Maybe (Writetime ServiceId), - Maybe ManagedBy, - Maybe (Writetime ManagedBy), - Maybe UserSSOId, - Maybe (Writetime UserSSOId), - Maybe EmailAddress, - Maybe (Writetime EmailAddress) - ) - --- the _2 lens does not work for a tuple this big -teamInReindexRow :: ReindexRow -> Maybe TeamId -teamInReindexRow (_f1, f2, _f3, _f4, _f5, _f6, _f7, _f8, _f9, _f10, _f11, _f12, _f13, _f14, _f15, _f16, _f17, _f18, _f19, _f20, _f21, _f22) = f2 - -reindexRowToIndexUser :: forall m. (MonadThrow m) => ReindexRow -> SearchVisibilityInbound -> m IndexUser -reindexRowToIndexUser - ( u, - mteam, - name, - tName, - status, - tStatus, - handle, - tHandle, - email, - tEmail, - colour, - tColour, - activated, - tActivated, - service, - tService, - managedBy, - tManagedBy, - ssoId, - tSsoId, - emailUnvalidated, - tEmailUnvalidated - ) - searchVisInbound = - do - iu <- - mkIndexUser u - <$> version - [ Just (v tName), - v <$> tStatus, - v <$> tHandle, - v <$> tEmail, - Just (v tColour), - Just (v tActivated), - v <$> tService, - v <$> tManagedBy, - v <$> tSsoId, - v <$> tEmailUnvalidated - ] - pure $ - if shouldIndex - then - iu - & set iuTeam mteam - . set iuName (Just name) - . set iuHandle handle - . set iuEmail email - . set iuColourId (Just colour) - . set iuAccountStatus status - . set iuSAMLIdP (idpUrl =<< ssoId) - . set iuManagedBy managedBy - . set iuCreatedAt (Just (writetimeToUTC tActivated)) - . set iuSearchVisibilityInbound (Just searchVisInbound) - . set iuScimExternalId (join $ User.scimExternalId <$> managedBy <*> ssoId) - . set iuSso (sso =<< ssoId) - . set iuEmailUnvalidated emailUnvalidated - else - iu - -- We insert a tombstone-style user here, as it's easier than deleting the old one. - -- It's mostly empty, but having the status here might be useful in the future. - & set iuAccountStatus status - where - v :: Writetime a -> Int64 - v = writetimeToInt64 - - version :: [Maybe Int64] -> m IndexVersion - version = mkIndexVersion . getMax . mconcat . fmap Max . catMaybes - - shouldIndex = - ( case status of - Nothing -> True - Just Active -> True - Just Suspended -> True - Just Deleted -> False - Just Ephemeral -> False - Just PendingInvitation -> False - ) - && activated -- FUTUREWORK: how is this adding to the first case? - && isNothing service - idpUrl :: UserSSOId -> Maybe Text - idpUrl (UserSSOId (SAML.UserRef (SAML.Issuer uri) _subject)) = - Just $ fromUri uri - idpUrl (UserScimExternalId _) = Nothing - - fromUri :: URI -> Text - fromUri = - decodeUtf8With lenientDecode - . toStrict - . toLazyByteString - . serializeURIRef - - sso :: UserSSOId -> Maybe Sso - sso userSsoId = do - (issuer, nameid) <- User.ssoIssuerAndNameId userSsoId - pure $ Sso {ssoIssuer = issuer, ssoNameId = nameid} - -getTeamSearchVisibilityInbound :: - TeamId -> - IndexIO (Maybe (Multi.TeamStatus SearchVisibilityInboundConfig)) -getTeamSearchVisibilityInbound tid = do - Multi.TeamFeatureNoConfigMultiResponse teamsStatuses <- getTeamSearchVisibilityInboundMulti [tid] - case filter ((== tid) . Multi.team) teamsStatuses of - [teamStatus] -> pure (Just teamStatus) - _ -> pure Nothing - -getTeamSearchVisibilityInboundMulti :: - [TeamId] -> - IndexIO (Multi.TeamFeatureNoConfigMultiResponse SearchVisibilityInboundConfig) -getTeamSearchVisibilityInboundMulti tids = do - galley <- asks idxGalley - serviceRequest' "galley" galley POST req >>= responseJsonThrow (ParseException "galley") - where - req = - paths ["i", "features-multi-teams", featureNameBS @SearchVisibilityInboundConfig] - . header "Content-Type" "application/json" - . expect2xx - . lbytes (encode $ Multi.TeamFeatureNoConfigMultiRequest tids) - - serviceRequest' :: - forall m. - (MonadIO m, MonadMask m, MonadHttp m) => - LT.Text -> - Endpoint -> - StdMethod -> - (Request -> Request) -> - m (Response (Maybe BL.ByteString)) - serviceRequest' nm endpoint m r = do - let service = mkEndpoint endpoint - recovering x3 rpcHandlers $ - const $ do - let rq = (RPC.method m . r) service - res <- try $ RPC.httpLbs rq id - case res of - Left x -> throwM $ RPCException nm rq x - Right x -> pure x - where - mkEndpoint service = RPC.host (encodeUtf8 (service ^. host)) . RPC.port (service ^. port) $ RPC.empty - - x3 :: RetryPolicy - x3 = limitRetries 3 <> exponentialBackoff 100000 - data ParseException = ParseException { _parseExceptionRemote :: !Text, _parseExceptionMsg :: String diff --git a/services/brig/src/Brig/User/Search/Index/Types.hs b/services/brig/src/Brig/User/Search/Index/Types.hs deleted file mode 100644 index 2630842be4d..00000000000 --- a/services/brig/src/Brig/User/Search/Index/Types.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.User.Search.Index.Types where - -import Brig.Types.Search -import Control.Lens (makeLenses) -import Control.Monad.Catch -import Data.Aeson -import Data.Handle (Handle) -import Data.Id -import Data.Json.Util (UTCTimeMillis (..), toUTCTimeMillis) -import Data.Text qualified as T -import Data.Text.ICU.Translit (trans, transliterate) -import Data.Time (UTCTime) -import Database.Bloodhound hiding (key) -import Database.Bloodhound.Internal.Client (DocVersion (DocVersion)) -import Imports -import Wire.API.Team.Role (Role) -import Wire.API.User -import Wire.API.User.Search (Sso (..)) - -data IndexDocUpdateType - = IndexUpdateIfNewerVersion - | IndexUpdateIfSameOrNewerVersion - -data IndexUpdate - = IndexUpdateUser IndexDocUpdateType IndexUser - | IndexUpdateUsers IndexDocUpdateType [IndexUser] - | IndexDeleteUser UserId - --- | Represents the ES *index*, ie. the attributes of a user that is searchable in ES. See also: --- 'UserDoc'. -data IndexUser = IndexUser - { _iuUserId :: UserId, - _iuVersion :: IndexVersion, - _iuTeam :: Maybe TeamId, - _iuName :: Maybe Name, - _iuHandle :: Maybe Handle, - _iuEmail :: Maybe EmailAddress, - _iuColourId :: Maybe ColourId, - _iuAccountStatus :: Maybe AccountStatus, - _iuSAMLIdP :: Maybe Text, - _iuManagedBy :: Maybe ManagedBy, - _iuCreatedAt :: Maybe UTCTime, - _iuRole :: Maybe Role, - _iuSearchVisibilityInbound :: Maybe SearchVisibilityInbound, - _iuScimExternalId :: Maybe Text, - _iuSso :: Maybe Sso, - _iuEmailUnvalidated :: Maybe EmailAddress - } - -data IndexQuery r = IndexQuery Query Filter [DefaultSort] - -data IndexError - = IndexUpdateError EsError - | IndexLookupError EsError - | IndexError Text - deriving (Show) - -instance Exception IndexError - -newtype IndexVersion = IndexVersion {docVersion :: DocVersion} - --- | Represents an ES *document*, ie. the subset of user attributes stored in ES. --- See also 'IndexUser'. --- --- If a user is not searchable, e.g. because the account got --- suspended, all fields except for the user id are set to 'Nothing' and --- consequently removed from the index. -data UserDoc = UserDoc - { udId :: UserId, - udTeam :: Maybe TeamId, - udName :: Maybe Name, - udNormalized :: Maybe Text, - udHandle :: Maybe Handle, - udEmail :: Maybe EmailAddress, - udColourId :: Maybe ColourId, - udAccountStatus :: Maybe AccountStatus, - udSAMLIdP :: Maybe Text, - udManagedBy :: Maybe ManagedBy, - udCreatedAt :: Maybe UTCTimeMillis, - udRole :: Maybe Role, - udSearchVisibilityInbound :: Maybe SearchVisibilityInbound, - udScimExternalId :: Maybe Text, - udSso :: Maybe Sso, - udEmailUnvalidated :: Maybe EmailAddress - } - deriving (Eq, Show) - --- Note: Keep this compatible with the FromJSON instances --- of 'Contact' and 'TeamContact' from 'Wire.API.User.Search -instance ToJSON UserDoc where - toJSON ud = - object - [ "id" .= udId ud, - "team" .= udTeam ud, - "name" .= udName ud, - "normalized" .= udNormalized ud, - "handle" .= udHandle ud, - "email" .= udEmail ud, - "accent_id" .= udColourId ud, - "account_status" .= udAccountStatus ud, - "saml_idp" .= udSAMLIdP ud, - "managed_by" .= udManagedBy ud, - "created_at" .= udCreatedAt ud, - "role" .= udRole ud, - (fromString . T.unpack $ searchVisibilityInboundFieldName) .= udSearchVisibilityInbound ud, - "scim_external_id" .= udScimExternalId ud, - "sso" .= udSso ud, - "email_unvalidated" .= udEmailUnvalidated ud - ] - -instance FromJSON UserDoc where - parseJSON = withObject "UserDoc" $ \o -> - UserDoc - <$> o .: "id" - <*> o .:? "team" - <*> o .:? "name" - <*> o .:? "normalized" - <*> o .:? "handle" - <*> o .:? "email" - <*> o .:? "accent_id" - <*> o .:? "account_status" - <*> o .:? "saml_idp" - <*> o .:? "managed_by" - <*> o .:? "created_at" - <*> o .:? "role" - <*> o .:? (fromString . T.unpack $ searchVisibilityInboundFieldName) - <*> o .:? "scim_external_id" - <*> o .:? "sso" - <*> o .:? "email_unvalidated" - -searchVisibilityInboundFieldName :: Text -searchVisibilityInboundFieldName = "search_visibility_inbound" - -makeLenses ''IndexUser - -mkIndexVersion :: (MonadThrow m, Integral a) => a -> m IndexVersion -mkIndexVersion i = - if i > fromIntegral (maxBound :: Int) - then throwM $ IndexError "Index overflow" - else pure . IndexVersion . fromMaybe maxBound . mkDocVersion . fromIntegral $ i - -mkIndexUser :: UserId -> IndexVersion -> IndexUser -mkIndexUser u v = - IndexUser - { _iuUserId = u, - _iuVersion = v, - _iuTeam = Nothing, - _iuName = Nothing, - _iuHandle = Nothing, - _iuEmail = Nothing, - _iuColourId = Nothing, - _iuAccountStatus = Nothing, - _iuSAMLIdP = Nothing, - _iuManagedBy = Nothing, - _iuCreatedAt = Nothing, - _iuRole = Nothing, - _iuSearchVisibilityInbound = Nothing, - _iuScimExternalId = Nothing, - _iuSso = Nothing, - _iuEmailUnvalidated = Nothing - } - -indexToDoc :: IndexUser -> UserDoc -indexToDoc iu = - UserDoc - { udId = _iuUserId iu, - udTeam = _iuTeam iu, - udName = _iuName iu, - udAccountStatus = _iuAccountStatus iu, - udNormalized = normalized . fromName <$> _iuName iu, - udHandle = _iuHandle iu, - udEmail = _iuEmail iu, - udColourId = _iuColourId iu, - udSAMLIdP = _iuSAMLIdP iu, - udManagedBy = _iuManagedBy iu, - udCreatedAt = toUTCTimeMillis <$> _iuCreatedAt iu, - udRole = _iuRole iu, - udSearchVisibilityInbound = _iuSearchVisibilityInbound iu, - udScimExternalId = _iuScimExternalId iu, - udSso = _iuSso iu, - udEmailUnvalidated = _iuEmailUnvalidated iu - } - --- | FUTUREWORK: Transliteration should be left to ElasticSearch (ICU plugin), but this will --- require a data migration. -normalized :: Text -> Text -normalized = transliterate (trans "Any-Latin; Latin-ASCII; Lower") - -docToIndex :: UserDoc -> IndexUser -docToIndex ud = - -- (Don't use 'mkIndexUser' here! With 'IndexUser', you get compiler warnings if you - -- forget to add new fields here.) - IndexUser - { _iuUserId = udId ud, - _iuVersion = IndexVersion (DocVersion 1), - _iuTeam = udTeam ud, - _iuName = udName ud, - _iuHandle = udHandle ud, - _iuEmail = udEmail ud, - _iuColourId = udColourId ud, - _iuAccountStatus = udAccountStatus ud, - _iuSAMLIdP = udSAMLIdP ud, - _iuManagedBy = udManagedBy ud, - _iuCreatedAt = fromUTCTimeMillis <$> udCreatedAt ud, - _iuRole = udRole ud, - _iuSearchVisibilityInbound = udSearchVisibilityInbound ud, - _iuScimExternalId = udScimExternalId ud, - _iuSso = udSso ud, - _iuEmailUnvalidated = udEmailUnvalidated ud - } From 082fdcdbb6576a16bf29609f1c64584b59fa439f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 15 Aug 2024 16:56:44 +0200 Subject: [PATCH 03/48] Add metrics to UserSearchSubsystem and IndexedUserStore Some metrics have been deleted as they are for bulk operations and there is no way for us to get those metrics because these operations don't run in an http request. --- .../polysemy-wire-zoo/polysemy-wire-zoo.cabal | 6 +- .../polysemy-wire-zoo/src/Wire/Sem/Metrics.hs | 21 +++++ .../src/Wire/Sem/Metrics/IO.hs | 11 +++ .../Wire/IndexedUserStore/ElasticSearch.hs | 27 +++++- .../src/Wire/UserSearch/Metrics.hs | 44 ++++++++++ .../Wire/UserSearchSubsystem/Interpreter.hs | 11 ++- libs/wire-subsystems/wire-subsystems.cabal | 2 + services/brig/src/Brig/User/Search/Index.hs | 84 ------------------- 8 files changed, 115 insertions(+), 91 deletions(-) create mode 100644 libs/polysemy-wire-zoo/src/Wire/Sem/Metrics.hs create mode 100644 libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs create mode 100644 libs/wire-subsystems/src/Wire/UserSearch/Metrics.hs diff --git a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal index 505874d7b6c..5d8bb12ab31 100644 --- a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal +++ b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal @@ -11,6 +11,7 @@ license: AGPL-3 build-type: Simple library + -- cabal-fmt: expand src exposed-modules: Polysemy.Testing Polysemy.TinyLog @@ -23,6 +24,8 @@ library Wire.Sem.Logger Wire.Sem.Logger.Level Wire.Sem.Logger.TinyLog + Wire.Sem.Metrics + Wire.Sem.Metrics.IO Wire.Sem.Now Wire.Sem.Now.Input Wire.Sem.Now.IO @@ -83,7 +86,7 @@ library build-depends: aeson - , base >=4.6 && <5.0 + , base >=4.6 && <5.0 , bytestring , cassandra-util , crypton @@ -94,6 +97,7 @@ library , polysemy , polysemy-check , polysemy-plugin + , prometheus-client , QuickCheck , saml2-web-sso , time diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics.hs new file mode 100644 index 00000000000..63cba3bce8a --- /dev/null +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.Sem.Metrics where + +import Imports +import Polysemy +import Prometheus (Counter, Gauge) + +-- | NOTE: Vectors would require non trival changes because +-- 'Prometheus.withLabel' take a paramter of type 'metric -> IO ()'. +data Metrics m a where + AddCounter :: Counter -> Double -> Metrics m () + AddGauge :: Gauge -> Double -> Metrics m () + +makeSem ''Metrics + +incCounter :: (Member Metrics r) => Counter -> Sem r () +incCounter c = addCounter c 1 + +incGauge :: (Member Metrics r) => Gauge -> Sem r () +incGauge c = addGauge c 1 diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs new file mode 100644 index 00000000000..dea2f006bb1 --- /dev/null +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs @@ -0,0 +1,11 @@ +module Wire.Sem.Metrics.IO where + +import Imports +import Polysemy +import qualified Prometheus as Prom +import Wire.Sem.Metrics + +runMetricsToIO :: (Member (Embed IO) r) => InterpreterFor Metrics r +runMetricsToIO = interpret $ \case + AddCounter c n -> embed . void $ Prom.addCounter @IO c n + AddGauge g n -> embed $ Prom.addGauge @IO g n diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index 5c2264dc6c4..0ac50b3e561 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -15,6 +15,9 @@ import Network.HTTP.Types import Polysemy import Polysemy.Error import Wire.IndexedUserStore +import Wire.Sem.Metrics (Metrics) +import Wire.Sem.Metrics qualified as Metrics +import Wire.UserSearch.Metrics import Wire.UserSearch.Types data ESConn = ESConn @@ -30,14 +33,30 @@ data IndexedUserStoreConfig = IndexedUserStoreConfig data IndexedUserStoreError = IndexUpdateError ES.EsError -interpretIndexedUserStoreES :: (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> InterpreterFor IndexedUserStore r +interpretIndexedUserStoreES :: + ( Member (Embed IO) r, + Member (Error IndexedUserStoreError) r, + Member Metrics r + ) => + IndexedUserStoreConfig -> + InterpreterFor IndexedUserStore r interpretIndexedUserStoreES cfg = interpret $ \case Upsert docId userDoc versioning -> upsertImpl cfg docId userDoc versioning UpdateTeamSearchVisibilityInbound tid vis -> updateTeamSearchVisibilityInboundImpl cfg tid vis BulkUpsert docs -> bulkUpsertImpl cfg docs -upsertImpl :: forall r. (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> ES.DocId -> UserDoc -> ES.VersionControl -> Sem r () +upsertImpl :: + forall r. + ( Member (Embed IO) r, + Member (Error IndexedUserStoreError) r, + Member Metrics r + ) => + IndexedUserStoreConfig -> + ES.DocId -> + UserDoc -> + ES.VersionControl -> + Sem r () upsertImpl cfg docId userDoc versioning = do runInBothES cfg indexDoc where @@ -45,10 +64,10 @@ upsertImpl cfg docId userDoc versioning = do indexDoc idx = do r <- ES.indexDocument idx mappingName settings userDoc docId unless (ES.isSuccess r || ES.isVersionConflict r) $ do - -- liftIO $ Prom.incCounter indexUpdateErrorCounter + lift $ Metrics.incCounter indexUpdateErrorCounter res <- liftIO $ ES.parseEsResponse r lift . throw . IndexUpdateError . either id id $ res - -- liftIO $ Prom.incCounter indexUpdateSuccessCounter + lift $ Metrics.incCounter indexUpdateSuccessCounter settings = ES.defaultIndexDocumentSettings {ES.idsVersionControl = versioning} diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Metrics.hs b/libs/wire-subsystems/src/Wire/UserSearch/Metrics.hs new file mode 100644 index 00000000000..656186a5f18 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSearch/Metrics.hs @@ -0,0 +1,44 @@ +module Wire.UserSearch.Metrics where + +import Imports +import Prometheus qualified as Prom + +{-# NOINLINE indexUpdateCounter #-} +indexUpdateCounter :: Prom.Counter +indexUpdateCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user_index_update_count", + Prom.metricHelp = "Number of updates on user index" + } + +{-# NOINLINE indexUpdateErrorCounter #-} +indexUpdateErrorCounter :: Prom.Counter +indexUpdateErrorCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user_index_update_err", + Prom.metricHelp = "Number of errors during user index update" + } + +{-# NOINLINE indexUpdateSuccessCounter #-} +indexUpdateSuccessCounter :: Prom.Counter +indexUpdateSuccessCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user_index_update_ok", + Prom.metricHelp = "Number of successful user index updates" + } + +{-# NOINLINE indexDeleteCounter #-} +indexDeleteCounter :: Prom.Counter +indexDeleteCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user_index_delete_count", + Prom.metricHelp = "Number of deletes on user index" + } diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index 010b3806119..e2e4ffacd03 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -21,6 +21,9 @@ import Wire.GalleyAPIAccess import Wire.IndexedUserStore (IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) +import Wire.Sem.Metrics (Metrics) +import Wire.Sem.Metrics qualified as Metrics +import Wire.UserSearch.Metrics import Wire.UserSearch.Types import Wire.UserSearchSubsystem import Wire.UserStore @@ -29,7 +32,8 @@ import Wire.UserStore.IndexUser interpretUserSearchSubsystem :: ( Member UserStore r, Member GalleyAPIAccess r, - Member IndexedUserStore r + Member IndexedUserStore r, + Member Metrics r ) => InterpreterFor UserSearchSubsystem r interpretUserSearchSubsystem = interpret \case @@ -55,7 +59,8 @@ syncUserImpl :: forall r. ( Member UserStore r, Member GalleyAPIAccess r, - Member IndexedUserStore r + Member IndexedUserStore r, + Member Metrics r ) => UserId -> Sem r () @@ -65,6 +70,7 @@ syncUserImpl uid = where delete :: Sem r () delete = do + Metrics.incCounter indexDeleteCounter IndexedUserStore.upsert (docId uid) (emptyUserDoc uid) ES.NoVersionControl upsert :: IndexUser -> Sem r () @@ -76,6 +82,7 @@ syncUserImpl uid = indexUser.teamId let userDoc = indexUserRowToDoc vis indexUser version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserRowToVersion indexUser + Metrics.incCounter indexUpdateCounter IndexedUserStore.upsert (docId uid) userDoc version syncAllUsersImpl :: diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index e155337e1d6..86ec0216ade 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -111,6 +111,7 @@ library Wire.StoredUser Wire.UserKeyStore Wire.UserKeyStore.Cassandra + Wire.UserSearch.Metrics Wire.UserSearch.Types Wire.UserSearchSubsystem Wire.UserSearchSubsystem.Interpreter @@ -176,6 +177,7 @@ library , polysemy-plugin , polysemy-time , polysemy-wire-zoo + , prometheus-client , QuickCheck , resource-pool , resourcet diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index cd90cdb9c22..b9f7c465efd 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -504,87 +504,3 @@ instance Show ParseException where ++ m instance Exception ParseException - ---------------------------------------------------------------------------------- --- Metrics - -{-# NOINLINE indexUpdateCounter #-} -indexUpdateCounter :: Prom.Counter -indexUpdateCounter = - Prom.unsafeRegister $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_update_count", - Prom.metricHelp = "Number of updates on user index" - } - -{-# NOINLINE indexUpdateErrorCounter #-} -indexUpdateErrorCounter :: Prom.Counter -indexUpdateErrorCounter = - Prom.unsafeRegister $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_update_err", - Prom.metricHelp = "Number of errors during user index update" - } - -{-# NOINLINE indexUpdateSuccessCounter #-} -indexUpdateSuccessCounter :: Prom.Counter -indexUpdateSuccessCounter = - Prom.unsafeRegister $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_update_ok", - Prom.metricHelp = "Number of successful user index updates" - } - -{-# NOINLINE indexBulkUpdateCounter #-} -indexBulkUpdateCounter :: Prom.Counter -indexBulkUpdateCounter = - Prom.unsafeRegister $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_update_bulk_count", - Prom.metricHelp = "Number of bulk updates on user index" - } - -{-# NOINLINE indexBulkUpdateErrorCounter #-} -indexBulkUpdateErrorCounter :: Prom.Counter -indexBulkUpdateErrorCounter = - Prom.unsafeRegister $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_update_bulk_err", - Prom.metricHelp = "Number of errors during bulk updates on user index" - } - -{-# NOINLINE indexBulkUpdateSuccessCounter #-} -indexBulkUpdateSuccessCounter :: Prom.Counter -indexBulkUpdateSuccessCounter = - Prom.unsafeRegister $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_update_bulk_ok", - Prom.metricHelp = "Number of successful bulk updates on user index" - } - -{-# NOINLINE indexBulkUpdateResponseCounter #-} -indexBulkUpdateResponseCounter :: Prom.Vector Prom.Label1 Prom.Counter -indexBulkUpdateResponseCounter = - Prom.unsafeRegister $ - Prom.vector ("status") $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_update_bulk_response", - Prom.metricHelp = "Number of successful bulk updates on user index" - } - -{-# NOINLINE indexDeleteCounter #-} -indexDeleteCounter :: Prom.Counter -indexDeleteCounter = - Prom.unsafeRegister $ - Prom.counter - Prom.Info - { Prom.metricName = "user_index_delete_count", - Prom.metricHelp = "Number of deletes on user index" - } From aac6ed0e047acddd6c3e5baf37bb53aa83b5006d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 19 Aug 2024 16:46:57 +0200 Subject: [PATCH 04/48] Run user serach index data migrations using subsystems --- .../src/Wire/Sem/Metrics/IO.hs | 5 + .../src/Wire/IndexedUserStore.hs | 10 + .../Wire/IndexedUserStore/ElasticSearch.hs | 24 ++- .../Migration/ElasticSearch.hs | 73 ++++++++ .../src/Wire/UserSearch/Migration.hs | 30 +++ .../src/Wire/UserSearchSubsystem.hs | 1 + .../Wire/UserSearchSubsystem/Interpreter.hs | 71 ++++++- libs/wire-subsystems/wire-subsystems.cabal | 2 + services/brig/brig.cabal | 2 - services/brig/src/Brig/Index/Eval.hs | 105 +++++++++-- services/brig/src/Brig/Index/Migrations.hs | 173 ------------------ .../brig/src/Brig/Index/Migrations/Types.hs | 100 ---------- 12 files changed, 299 insertions(+), 297 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/IndexedUserStore/Migration/ElasticSearch.hs create mode 100644 libs/wire-subsystems/src/Wire/UserSearch/Migration.hs delete mode 100644 services/brig/src/Brig/Index/Migrations.hs delete mode 100644 services/brig/src/Brig/Index/Migrations/Types.hs diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs index dea2f006bb1..1b357927c87 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Metrics/IO.hs @@ -9,3 +9,8 @@ runMetricsToIO :: (Member (Embed IO) r) => InterpreterFor Metrics r runMetricsToIO = interpret $ \case AddCounter c n -> embed . void $ Prom.addCounter @IO c n AddGauge g n -> embed $ Prom.addGauge @IO g n + +ignoreMetrics :: InterpreterFor Metrics r +ignoreMetrics = interpret $ \case + AddCounter _ _ -> pure () + AddGauge _ _ -> pure () diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs index 232a61f2f42..89569393a2f 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs @@ -4,7 +4,9 @@ module Wire.IndexedUserStore where import Data.Id import Database.Bloodhound.Types +import Imports import Polysemy +import Wire.UserSearch.Migration import Wire.UserSearch.Types data IndexedUserStore m a where @@ -12,5 +14,13 @@ data IndexedUserStore m a where UpdateTeamSearchVisibilityInbound :: TeamId -> SearchVisibilityInbound -> IndexedUserStore m () -- | Will only be applied to main ES index and not the additional one BulkUpsert :: [(DocId, UserDoc, VersionControl)] -> IndexedUserStore m () + DoesIndexExist :: IndexedUserStore m Bool makeSem ''IndexedUserStore + +data IndexedUserMigrationStore m a where + EnsureMigrationIndex :: IndexedUserMigrationStore m () + GetLatestMigrationVersion :: IndexedUserMigrationStore m MigrationVersion + PersistMigrationVersion :: MigrationVersion -> IndexedUserMigrationStore m () + +makeSem ''IndexedUserMigrationStore diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index 0ac50b3e561..34900e178a3 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -31,7 +31,13 @@ data IndexedUserStoreConfig = IndexedUserStoreConfig additionalConn :: Maybe ESConn } -data IndexedUserStoreError = IndexUpdateError ES.EsError +data IndexedUserStoreError + = IndexUpdateError ES.EsError + | IndexLookupError ES.EsError + | IndexError Text + deriving (Show) + +instance Exception IndexedUserStoreError interpretIndexedUserStoreES :: ( Member (Embed IO) r, @@ -45,6 +51,7 @@ interpretIndexedUserStoreES cfg = Upsert docId userDoc versioning -> upsertImpl cfg docId userDoc versioning UpdateTeamSearchVisibilityInbound tid vis -> updateTeamSearchVisibilityInboundImpl cfg tid vis BulkUpsert docs -> bulkUpsertImpl cfg docs + DoesIndexExist -> doesIndexExistImpl cfg upsertImpl :: forall r. @@ -58,7 +65,7 @@ upsertImpl :: ES.VersionControl -> Sem r () upsertImpl cfg docId userDoc versioning = do - runInBothES cfg indexDoc + void $ runInBothES cfg indexDoc where indexDoc :: ES.IndexName -> ES.BH (Sem r) () indexDoc idx = do @@ -73,7 +80,7 @@ upsertImpl cfg docId userDoc versioning = do updateTeamSearchVisibilityInboundImpl :: forall r. (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> TeamId -> SearchVisibilityInbound -> Sem r () updateTeamSearchVisibilityInboundImpl cfg tid vis = - runInBothES cfg updateAllDocs + void $ runInBothES cfg updateAllDocs where updateAllDocs :: ES.IndexName -> ES.BH (Sem r) () updateAllDocs idx = do @@ -150,12 +157,17 @@ bulkUpsertImpl cfg docs = do ] ] -runInBothES :: (Monad m) => IndexedUserStoreConfig -> (ES.IndexName -> ES.BH m a) -> m a +doesIndexExistImpl :: (Member (Embed IO) r) => IndexedUserStoreConfig -> Sem r Bool +doesIndexExistImpl cfg = do + (mainExists, fromMaybe True -> additionalExists) <- runInBothES cfg ES.indexExists + pure $ mainExists && additionalExists + +runInBothES :: (Monad m) => IndexedUserStoreConfig -> (ES.IndexName -> ES.BH m a) -> m (a, Maybe a) runInBothES cfg f = do x <- ES.runBH cfg.conn.env $ f cfg.conn.indexName - forM_ cfg.additionalConn $ \additional -> + y <- forM cfg.additionalConn $ \additional -> ES.runBH additional.env $ f additional.indexName - pure x + pure (x, y) mappingName :: ES.MappingName mappingName = ES.MappingName "user" diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Migration/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Migration/ElasticSearch.hs new file mode 100644 index 00000000000..9097fa8c147 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Migration/ElasticSearch.hs @@ -0,0 +1,73 @@ +module Wire.IndexedUserStore.Migration.ElasticSearch where + +import Data.Aeson +import Data.Text qualified as Text +import Database.Bloodhound qualified as ES +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.TinyLog +import System.Logger.Message qualified as Log +import Wire.IndexedUserStore +import Wire.Sem.Logger qualified as Log +import Wire.UserSearch.Migration + +interpretIndexedUserMigrationStoreES :: (Member (Embed IO) r, Member (Error MigrationException) r, Member TinyLog r) => ES.BHEnv -> InterpreterFor IndexedUserMigrationStore r +interpretIndexedUserMigrationStoreES env = interpret $ \case + EnsureMigrationIndex -> ensureMigrationIndexImpl env + GetLatestMigrationVersion -> getLatestMigrationVersionImpl env + PersistMigrationVersion v -> persistMigrationVersionImpl env v + +ensureMigrationIndexImpl :: (Member TinyLog r, Member (Embed IO) r, Member (Error MigrationException) r) => ES.BHEnv -> Sem r () +ensureMigrationIndexImpl env = do + unlessM (ES.runBH env $ ES.indexExists migrationIndexName) $ do + Log.info $ + Log.msg (Log.val "Creating migrations index, used for tracking which migrations have run") + ES.runBH env (ES.createIndexWith [] 1 migrationIndexName) + >>= throwIfNotCreated CreateMigrationIndexFailed + ES.runBH env (ES.putMapping migrationIndexName migrationMappingName migrationIndexMapping) + >>= throwIfNotCreated PutMappingFailed + where + throwIfNotCreated mkErr response = + unless (ES.isSuccess response) $ + throw $ + mkErr (show response) + +getLatestMigrationVersionImpl :: (Member (Embed IO) r, Member (Error MigrationException) r) => ES.BHEnv -> Sem r MigrationVersion +getLatestMigrationVersionImpl env = do + reply <- ES.runBH env $ ES.searchByIndex migrationIndexName (ES.mkSearch Nothing Nothing) + resp <- liftIO $ ES.parseEsResponse reply + result <- either (throw . FetchMigrationVersionsFailed . show) pure resp + let versions = map ES.hitSource $ ES.hits . ES.searchHits $ result + case versions of + [] -> + pure $ MigrationVersion 0 + vs -> + if any isNothing vs + then throw $ VersionSourceMissing result + else pure $ maximum $ catMaybes vs + +persistMigrationVersionImpl :: (Member (Embed IO) r, Member TinyLog r, Member (Error MigrationException) r) => ES.BHEnv -> MigrationVersion -> Sem r () +persistMigrationVersionImpl env v = do + let docId = ES.DocId . Text.pack . show $ migrationVersion v + persistResponse <- ES.runBH env $ ES.indexDocument migrationIndexName migrationMappingName ES.defaultIndexDocumentSettings v docId + if ES.isCreated persistResponse + then do + Log.info $ + Log.msg (Log.val "Migration success recorded") + . Log.field "migrationVersion" v + else throw $ PersistVersionFailed v $ show persistResponse + +migrationIndexName :: ES.IndexName +migrationIndexName = ES.IndexName "wire_brig_migrations" + +migrationMappingName :: ES.MappingName +migrationMappingName = ES.MappingName "wire_brig_migrations" + +migrationIndexMapping :: Value +migrationIndexMapping = + object + [ "properties" + .= object + ["migration_version" .= object ["index" .= True, "type" .= ("integer" :: Text)]] + ] diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Migration.hs b/libs/wire-subsystems/src/Wire/UserSearch/Migration.hs new file mode 100644 index 00000000000..da343e721b1 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSearch/Migration.hs @@ -0,0 +1,30 @@ +module Wire.UserSearch.Migration where + +import Data.Aeson +import Database.Bloodhound.Types qualified as ES +import Imports +import Numeric.Natural +import System.Logger.Class (ToBytes (..)) + +newtype MigrationVersion = MigrationVersion {migrationVersion :: Natural} + deriving (Show, Eq, Ord) + +instance ToJSON MigrationVersion where + toJSON (MigrationVersion v) = object ["migration_version" .= v] + +instance FromJSON MigrationVersion where + parseJSON = withObject "MigrationVersion" $ \o -> MigrationVersion <$> o .: "migration_version" + +instance ToBytes MigrationVersion where + bytes = bytes . toInteger . migrationVersion + +data MigrationException + = CreateMigrationIndexFailed String + | FetchMigrationVersionsFailed String + | PersistVersionFailed MigrationVersion String + | PutMappingFailed String + | TargetIndexAbsent + | VersionSourceMissing (ES.SearchResult MigrationVersion) + deriving (Show) + +instance Exception MigrationException diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs index d2ac19ccedc..5b8b23cb2e2 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs @@ -52,5 +52,6 @@ data UserSearchSubsystemBulk m a where -- | Overwrite all users in the ES index, use it when trying to fix some -- inconsistency or while introducing a new field in the mapping. ForceSyncAllUsers :: UserSearchSubsystemBulk m () + MigrateData :: UserSearchSubsystemBulk m () makeSem ''UserSearchSubsystemBulk diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index e2e4ffacd03..ed3b8ac6057 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -12,18 +12,21 @@ import Data.Set qualified as Set import Database.Bloodhound.Types qualified as ES import Imports import Polysemy +import Polysemy.Error import Polysemy.TinyLog +import Polysemy.TinyLog qualified as Log import System.Logger.Message qualified as Log import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) import Wire.API.Team.Feature import Wire.API.User.Search import Wire.GalleyAPIAccess -import Wire.IndexedUserStore (IndexedUserStore) +import Wire.IndexedUserStore (IndexedUserMigrationStore, IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) import Wire.Sem.Metrics (Metrics) import Wire.Sem.Metrics qualified as Metrics import Wire.UserSearch.Metrics +import Wire.UserSearch.Migration import Wire.UserSearch.Types import Wire.UserSearchSubsystem import Wire.UserStore @@ -48,12 +51,15 @@ interpretUserSearchSubsystemBulk :: Member UserStore r, Member (Concurrency Unsafe) r, Member GalleyAPIAccess r, - Member IndexedUserStore r + Member IndexedUserStore r, + Member (Error MigrationException) r, + Member IndexedUserMigrationStore r ) => InterpreterFor UserSearchSubsystemBulk r interpretUserSearchSubsystemBulk = interpret \case - SyncAllUsers -> syncAllUsersImpl (ES.ExternalGT) - ForceSyncAllUsers -> syncAllUsersImpl (ES.ExternalGTE) + SyncAllUsers -> syncAllUsersImpl + ForceSyncAllUsers -> forceSyncAllUsersImpl + MigrateData -> migrateDataImpl syncUserImpl :: forall r. @@ -86,6 +92,28 @@ syncUserImpl uid = IndexedUserStore.upsert (docId uid) userDoc version syncAllUsersImpl :: + forall r. + ( Member UserStore r, + Member TinyLog r, + Member (Concurrency 'Unsafe) r, + Member GalleyAPIAccess r, + Member IndexedUserStore r + ) => + Sem r () +syncAllUsersImpl = syncAllUsersWithVersion ES.ExternalGT + +forceSyncAllUsersImpl :: + forall r. + ( Member UserStore r, + Member TinyLog r, + Member (Concurrency 'Unsafe) r, + Member GalleyAPIAccess r, + Member IndexedUserStore r + ) => + Sem r () +forceSyncAllUsersImpl = syncAllUsersWithVersion ES.ExternalGTE + +syncAllUsersWithVersion :: forall r. ( Member UserStore r, Member TinyLog r, @@ -95,7 +123,7 @@ syncAllUsersImpl :: ) => (ES.ExternalDocVersion -> ES.VersionControl) -> Sem r () -syncAllUsersImpl mkVersion = +syncAllUsersWithVersion mkVersion = runConduit $ paginateWithStateC getIndexUsersPaginated .| logPage @@ -128,6 +156,39 @@ searchUserImpl = undefined browseTeamImpl :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> Sem r [TeamContact] browseTeamImpl = undefined +migrateDataImpl :: + ( Member IndexedUserStore r, + Member (Error MigrationException) r, + Member IndexedUserMigrationStore r, + Member UserStore r, + Member (Concurrency Unsafe) r, + Member GalleyAPIAccess r, + Member TinyLog r + ) => + Sem r () +migrateDataImpl = do + unlessM IndexedUserStore.doesIndexExist $ + throw TargetIndexAbsent + IndexedUserStore.ensureMigrationIndex + foundVersion <- IndexedUserStore.getLatestMigrationVersion + if expectedMigrationVersion > foundVersion + then do + Log.info $ + Log.msg (Log.val "Migration necessary.") + . Log.field "expectedVersion" expectedMigrationVersion + . Log.field "foundVersion" foundVersion + forceSyncAllUsersImpl + IndexedUserStore.persistMigrationVersion expectedMigrationVersion + else do + Log.info $ + Log.msg (Log.val "No migration necessary.") + . Log.field "expectedVersion" expectedMigrationVersion + . Log.field "foundVersion" foundVersion + +-- | Increase this number any time you want to force reindexing. +expectedMigrationVersion :: MigrationVersion +expectedMigrationVersion = MigrationVersion 6 + docId :: UserId -> ES.DocId docId uid = ES.DocId (idToText uid) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 86ec0216ade..3ee68eac707 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -93,6 +93,7 @@ library Wire.HashPassword Wire.IndexedUserStore Wire.IndexedUserStore.ElasticSearch + Wire.IndexedUserStore.Migration.ElasticSearch Wire.InternalEvent Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter @@ -112,6 +113,7 @@ library Wire.UserKeyStore Wire.UserKeyStore.Cassandra Wire.UserSearch.Metrics + Wire.UserSearch.Migration Wire.UserSearch.Types Wire.UserSearchSubsystem Wire.UserSearchSubsystem.Interpreter diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index fa238ed829b..9ecf49e3f91 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -123,8 +123,6 @@ library Brig.Effects.UserPendingActivationStore.Cassandra Brig.Federation.Client Brig.Index.Eval - Brig.Index.Migrations - Brig.Index.Migrations.Types Brig.Index.Options Brig.Index.Types Brig.InternalEvent.Process diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index c19d000c5d9..79269500f69 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -23,13 +23,13 @@ module Brig.Index.Eval where import Brig.App (initHttpManagerWithTLSConfig, mkIndexEnv) -import Brig.Index.Migrations import Brig.Index.Options import Brig.Options import Brig.User.Search.Index import Cassandra qualified as C import Cassandra.Options import Cassandra.Util (defInitCassandra) +import Control.Exception (throwIO) import Control.Lens import Control.Monad.Catch import Control.Retry @@ -37,11 +37,97 @@ import Data.Aeson (FromJSON) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.UTF8 qualified as UTF8 import Data.Credentials (Credentials (..)) +import Data.Id import Database.Bloodhound qualified as ES +import Database.Bloodhound.Internal.Client (BHEnv (..)) import Imports +import Polysemy +import Polysemy.Error +import Polysemy.TinyLog hiding (Logger) import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..)) import Util.Options (initCredentials) +import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess.Rpc +import Wire.IndexedUserStore +import Wire.IndexedUserStore.ElasticSearch +import Wire.IndexedUserStore.Migration.ElasticSearch +import Wire.ParseException +import Wire.Rpc +import Wire.Sem.Concurrency +import Wire.Sem.Concurrency.IO +import Wire.Sem.Logger.TinyLog +import Wire.Sem.Metrics +import Wire.Sem.Metrics.IO +import Wire.UserSearch.Migration (MigrationException) +import Wire.UserSearchSubsystem (UserSearchSubsystem, UserSearchSubsystemBulk) +import Wire.UserSearchSubsystem qualified as UserSearchSubsystem +import Wire.UserSearchSubsystem.Interpreter +import Wire.UserStore +import Wire.UserStore.Cassandra + +type BrigIndexEffectStack = + [ UserSearchSubsystemBulk, + UserSearchSubsystem, + UserStore, + IndexedUserStore, + Error IndexedUserStoreError, + IndexedUserMigrationStore, + Error MigrationException, + GalleyAPIAccess, + Error ParseException, + Rpc, + Metrics, + TinyLog, + Concurrency 'Unsafe, + Embed IO, + Final IO + ] + +runSem :: ESConnectionSettings -> CassandraSettings -> Endpoint -> Logger -> Sem BrigIndexEffectStack a -> IO a +runSem esConn cas galleyEndpoint logger action = do + mgr <- initHttpManagerWithTLSConfig esConn.esInsecureSkipVerifyTls esConn.esCaCert + mEsCreds <- for esConn.esCredentials initCredentials + casClient <- defInitCassandra (toCassandraOpts cas) logger + let bhEnv = + BHEnv + { bhServer = toESServer esConn.esServer, + bhManager = mgr, + bhRequestHook = maybe pure (\creds -> ES.basicAuthHook (ES.EsUsername creds.username) (ES.EsPassword creds.password)) mEsCreds + } + indexedUserStoreConfig = + IndexedUserStoreConfig + { conn = + ESConn + { indexName = esConn.esIndex, + env = bhEnv, + credentials = mEsCreds + }, + additionalConn = Nothing + } + reqId = (RequestId "brig-index") + runFinal + . embedToFinal + . unsafelyPerformConcurrency + . loggerToTinyLogReqId reqId logger + . ignoreMetrics + . runRpcWithHttp mgr reqId + . throwErrorToIOFinal @ParseException + . interpretGalleyAPIAccessToRpc mempty galleyEndpoint + . throwErrorToIOFinal @MigrationException + . interpretIndexedUserMigrationStoreES bhEnv + . throwErrorToIOFinal @IndexedUserStoreError + . interpretIndexedUserStoreES indexedUserStoreConfig + . interpretUserStoreCassandra casClient + . interpretUserSearchSubsystem + . interpretUserSearchSubsystemBulk + $ action + +throwErrorToIOFinal :: (Exception e, Member (Final IO) r) => InterpreterFor (Error e) r +throwErrorToIOFinal action = do + runError action >>= \case + Left e -> embedFinal $ throwIO e + Right a -> pure a runCommand :: Logger -> Command -> IO () runCommand l = \case @@ -52,18 +138,17 @@ runCommand l = \case e <- initIndex (es ^. esConnection) galley runIndexIO e $ resetIndex (mkCreateIndexSettings es) Reindex es cas galley -> do - e <- initIndex (es ^. esConnection) galley - c <- initDb cas - runReindexIO e c reindexAll + runSem (es ^. esConnection) cas galley l $ + UserSearchSubsystem.syncAllUsers ReindexSameOrNewer es cas galley -> do - e <- initIndex (es ^. esConnection) galley - c <- initDb cas - runReindexIO e c reindexAllIfSameOrNewer + runSem (es ^. esConnection) cas galley l $ + UserSearchSubsystem.forceSyncAllUsers UpdateMapping esConn galley -> do e <- initIndex esConn galley runIndexIO e updateMapping Migrate es cas galley -> do - migrate l es cas galley + runSem (es ^. esConnection) cas galley l $ + UserSearchSubsystem.migrateData ReindexFromAnotherIndex reindexSettings -> do mgr <- initHttpManagerWithTLSConfig @@ -87,7 +172,7 @@ runCommand l = \case Log.info l $ Log.msg ("Reindexing" :: ByteString) . Log.field "from" (show src) . Log.field "to" (show dest) eitherTaskNodeId <- ES.reindexAsync $ ES.mkReindexRequest src dest case eitherTaskNodeId of - Left err -> throwM $ ReindexFromAnotherIndexError $ "Error occurred while running reindex: " <> show err + Left e -> throwM $ ReindexFromAnotherIndexError $ "Error occurred while running reindex: " <> show e Right taskNodeId -> do Log.info l $ Log.field "taskNodeId" (show taskNodeId) waitForTaskToComplete @ES.ReindexResponse timeoutSeconds taskNodeId @@ -116,8 +201,6 @@ runCommand l = \case let env = ES.mkBHEnv (toESServer esURI) mgr in maybe env (\(creds :: Credentials) -> env {ES.bhRequestHook = ES.basicAuthHook (ES.EsUsername creds.username) (ES.EsPassword creds.password)}) mCreds - initDb cas = defInitCassandra (toCassandraOpts cas) l - waitForTaskToComplete :: forall a m. (ES.MonadBH m, MonadThrow m, FromJSON a) => Int -> ES.TaskNodeId -> m () waitForTaskToComplete timeoutSeconds taskNodeId = do -- Delay is 0.1 seconds, so retries are limited to timeoutSeconds * 10 diff --git a/services/brig/src/Brig/Index/Migrations.hs b/services/brig/src/Brig/Index/Migrations.hs deleted file mode 100644 index 2fbb8ce5455..00000000000 --- a/services/brig/src/Brig/Index/Migrations.hs +++ /dev/null @@ -1,173 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Index.Migrations - ( migrate, - ) -where - -import Brig.App (initHttpManagerWithTLSConfig) -import Brig.Index.Migrations.Types -import Brig.Index.Options qualified as Opts -import Brig.User.Search.Index qualified as Search -import Cassandra.Util (defInitCassandra) -import Control.Lens (to, view, (^.)) -import Control.Monad.Catch (MonadThrow, catchAll, finally, throwM) -import Data.Aeson (Value, object, (.=)) -import Data.Credentials (Credentials (..)) -import Data.Text qualified as Text -import Database.Bloodhound qualified as ES -import Imports -import Network.HTTP.Client qualified as HTTP -import System.Logger.Class (Logger) -import System.Logger.Class qualified as Log -import System.Logger.Extended (runWithLogger) -import Util.Options qualified as Options - -migrate :: Logger -> Opts.ElasticSettings -> Opts.CassandraSettings -> Options.Endpoint -> IO () -migrate l es cas galleyEndpoint = do - env <- mkEnv l es cas galleyEndpoint - finally (go env `catchAll` logAndThrowAgain) (cleanup env) - where - go :: Env -> IO () - go env = - runMigrationAction env $ do - failIfIndexAbsent (es ^. Opts.esConnection . to Opts.esIndex) - createMigrationsIndexIfNotPresent - runMigration expectedMigrationVersion - - logAndThrowAgain :: forall a. SomeException -> IO a - logAndThrowAgain e = do - runWithLogger l $ - Log.err $ - Log.msg (Log.val "Migration failed with exception") . Log.field "exception" (show e) - throwM e - --- | Increase this number any time you want to force reindexing. -expectedMigrationVersion :: MigrationVersion -expectedMigrationVersion = MigrationVersion 6 - -indexName :: ES.IndexName -indexName = ES.IndexName "wire_brig_migrations" - -indexMappingName :: ES.MappingName -indexMappingName = ES.MappingName "wire_brig_migrations" - -indexMapping :: Value -indexMapping = - object - [ "properties" - .= object - ["migration_version" .= object ["index" .= True, "type" .= ("integer" :: Text)]] - ] - -mkEnv :: Logger -> Opts.ElasticSettings -> Opts.CassandraSettings -> Options.Endpoint -> IO Env -mkEnv l es cas galleyEndpoint = do - env <- do - esMgr <- initHttpManagerWithTLSConfig (es ^. Opts.esConnection . to Opts.esInsecureSkipVerifyTls) (es ^. Opts.esConnection . to Opts.esCaCert) - pure $ ES.mkBHEnv (Opts.toESServer (es ^. Opts.esConnection . to Opts.esServer)) esMgr - mCreds <- for (es ^. Opts.esConnection . to Opts.esCredentials) Options.initCredentials - let envWithAuth = maybe env (\(creds :: Credentials) -> env {ES.bhRequestHook = ES.basicAuthHook (ES.EsUsername creds.username) (ES.EsPassword creds.password)}) mCreds - rpcMgr <- HTTP.newManager HTTP.defaultManagerSettings - Env envWithAuth - <$> initCassandra - <*> initLogger - <*> pure (view (Opts.esConnection . to Opts.esIndex) es) - <*> pure mCreds - <*> pure rpcMgr - <*> pure galleyEndpoint - where - initCassandra = defInitCassandra (Opts.toCassandraOpts cas) l - - initLogger = pure l - -createMigrationsIndexIfNotPresent :: (MonadThrow m, ES.MonadBH m, Log.MonadLogger m) => m () -createMigrationsIndexIfNotPresent = - do - unlessM (ES.indexExists indexName) $ do - Log.info $ - Log.msg (Log.val "Creating migrations index, used for tracking which migrations have run") - ES.createIndexWith [] 1 indexName - >>= throwIfNotCreated CreateMigrationIndexFailed - ES.putMapping indexName indexMappingName indexMapping - >>= throwIfNotCreated PutMappingFailed - where - throwIfNotCreated err response = - unless (ES.isSuccess response) $ - throwM $ - err (show response) - -failIfIndexAbsent :: (MonadThrow m, ES.MonadBH m) => ES.IndexName -> m () -failIfIndexAbsent targetIndex = - unlessM - (ES.indexExists targetIndex) - (throwM $ TargetIndexAbsent targetIndex) - --- | Runs only the migrations which need to run -runMigration :: MigrationVersion -> MigrationActionT IO () -runMigration expectedVersion = do - foundVersion <- latestMigrationVersion - if expectedVersion > foundVersion - then do - Log.info $ - Log.msg (Log.val "Migration necessary.") - . Log.field "expectedVersion" expectedVersion - . Log.field "foundVersion" foundVersion - Search.reindexAllIfSameOrNewer - persistVersion expectedVersion - else do - Log.info $ - Log.msg (Log.val "No migration necessary.") - . Log.field "expectedVersion" expectedVersion - . Log.field "foundVersion" foundVersion - -persistVersion :: (MonadThrow m, MonadIO m) => MigrationVersion -> MigrationActionT m () -persistVersion v = - let docId = ES.DocId . Text.pack . show $ migrationVersion v - in do - persistResponse <- ES.indexDocument indexName indexMappingName ES.defaultIndexDocumentSettings v docId - if ES.isCreated persistResponse - then do - Log.info $ - Log.msg (Log.val "Migration success recorded") - . Log.field "migrationVersion" v - else throwM $ PersistVersionFailed v $ show persistResponse - --- | Which version is the table space currently running on? -latestMigrationVersion :: (MonadThrow m, MonadIO m) => MigrationActionT m MigrationVersion -latestMigrationVersion = do - resp <- ES.parseEsResponse =<< ES.searchByIndex indexName (ES.mkSearch Nothing Nothing) - result <- either (throwM . FetchMigrationVersionsFailed . show) pure resp - let versions = map ES.hitSource $ ES.hits . ES.searchHits $ result - case versions of - [] -> - pure $ MigrationVersion 0 - vs -> - if any isNothing vs - then throwM $ VersionSourceMissing result - else pure $ maximum $ catMaybes vs - -data MigrationException - = CreateMigrationIndexFailed String - | FetchMigrationVersionsFailed String - | PersistVersionFailed MigrationVersion String - | PutMappingFailed String - | TargetIndexAbsent ES.IndexName - | VersionSourceMissing (ES.SearchResult MigrationVersion) - deriving (Show) - -instance Exception MigrationException diff --git a/services/brig/src/Brig/Index/Migrations/Types.hs b/services/brig/src/Brig/Index/Migrations/Types.hs deleted file mode 100644 index 7854ce67aae..00000000000 --- a/services/brig/src/Brig/Index/Migrations/Types.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Index.Migrations.Types where - -import Brig.User.Search.Index qualified as Search -import Cassandra qualified as C -import Control.Monad.Catch (MonadThrow) -import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) -import Data.Credentials (Credentials) -import Database.Bloodhound qualified as ES -import Imports -import Network.HTTP.Client (Manager) -import Numeric.Natural (Natural) -import System.Logger qualified as Logger -import System.Logger.Class (MonadLogger (..), ToBytes (..)) -import Util.Options (Endpoint) - -newtype MigrationVersion = MigrationVersion {migrationVersion :: Natural} - deriving (Show, Eq, Ord) - -instance ToJSON MigrationVersion where - toJSON (MigrationVersion v) = object ["migration_version" .= v] - -instance FromJSON MigrationVersion where - parseJSON = withObject "MigrationVersion" $ \o -> MigrationVersion <$> o .: "migration_version" - -instance ToBytes MigrationVersion where - bytes = bytes . toInteger . migrationVersion - -newtype MigrationActionT m a = MigrationActionT {unMigrationAction :: ReaderT Env m a} - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadThrow, - MonadReader Env - ) - -instance MonadTrans MigrationActionT where - lift = MigrationActionT . lift - -instance (MonadIO m, MonadThrow m) => C.MonadClient (MigrationActionT m) where - liftClient = liftCassandra - localState f = local (\env -> env {cassandraClientState = f $ cassandraClientState env}) - -instance (MonadIO m) => MonadLogger (MigrationActionT m) where - log level f = do - env <- ask - Logger.log (logger env) level f - -instance (MonadIO m) => Search.MonadIndexIO (MigrationActionT m) where - liftIndexIO m = do - Env {..} <- ask - let indexEnv = Search.IndexEnv logger bhEnv Nothing searchIndex Nothing Nothing galleyEndpoint httpManager searchIndexCredentials - Search.runIndexIO indexEnv m - -instance (MonadIO m) => ES.MonadBH (MigrationActionT m) where - getBHEnv = bhEnv <$> ask - -data Env = Env - { bhEnv :: ES.BHEnv, - cassandraClientState :: C.ClientState, - logger :: Logger.Logger, - searchIndex :: ES.IndexName, - searchIndexCredentials :: Maybe Credentials, - httpManager :: Manager, - galleyEndpoint :: Endpoint - } - -runMigrationAction :: Env -> MigrationActionT m a -> m a -runMigrationAction env action = - runReaderT (unMigrationAction action) env - -liftCassandra :: (MonadIO m) => C.Client a -> MigrationActionT m a -liftCassandra m = do - env <- ask - lift $ C.runClient (cassandraClientState env) m - -cleanup :: (MonadIO m) => Env -> m () -cleanup env = do - C.shutdown (cassandraClientState env) From c234972eae010a4d96048164fc0ac29e8120d1bb Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 19 Aug 2024 17:35:01 +0200 Subject: [PATCH 05/48] Remove explicit creds from ESConn --- .../src/Wire/IndexedUserStore/ElasticSearch.hs | 16 ++++++---------- services/brig/src/Brig/Index/Eval.hs | 5 ++--- 2 files changed, 8 insertions(+), 13 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index 34900e178a3..4c99b32e8ee 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -4,7 +4,6 @@ import Data.Aeson import Data.Aeson.Key qualified as Key import Data.ByteString.Builder import Data.ByteString.Conversion -import Data.Credentials import Data.Id import Data.Text qualified as Text import Data.Text.Encoding qualified as Text @@ -22,7 +21,6 @@ import Wire.UserSearch.Types data ESConn = ESConn { env :: ES.BHEnv, - credentials :: Maybe Credentials, indexName :: ES.IndexName } @@ -115,17 +113,15 @@ bulkUpsertImpl cfg docs = do ES.IndexName idx = cfg.conn.indexName ES.MappingName mpp = mappingName (ES.Server base) = ES.bhServer bhe - authHeaders = maybe [] ((: []) . mkBasicAuthHeader) cfg.conn.credentials - req <- embed $ parseRequest (Text.unpack $ base <> "/" <> idx <> "/" <> mpp <> "/_bulk") - res <- - embed $ - httpLbs - req + baseReq <- embed $ parseRequest (Text.unpack $ base <> "/" <> idx <> "/" <> mpp <> "/_bulk") + let reqWithoutCreds = + baseReq { method = "POST", - requestHeaders = [(hContentType, "application/x-ndjson")] <> authHeaders, -- sic + requestHeaders = [(hContentType, "application/x-ndjson")], requestBody = RequestBodyLBS (toLazyByteString (foldMap encodeActionAndData docs)) } - (ES.bhManager bhe) + req <- embed $ bhe.bhRequestHook reqWithoutCreds + res <- embed $ httpLbs req (ES.bhManager bhe) unless (ES.isSuccess res) $ do parsedRes <- liftIO $ ES.parseEsResponse res throw . IndexUpdateError . either id id $ parsedRes diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 79269500f69..54420e7f899 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -87,7 +87,7 @@ type BrigIndexEffectStack = runSem :: ESConnectionSettings -> CassandraSettings -> Endpoint -> Logger -> Sem BrigIndexEffectStack a -> IO a runSem esConn cas galleyEndpoint logger action = do mgr <- initHttpManagerWithTLSConfig esConn.esInsecureSkipVerifyTls esConn.esCaCert - mEsCreds <- for esConn.esCredentials initCredentials + mEsCreds :: Maybe Credentials <- for esConn.esCredentials initCredentials casClient <- defInitCassandra (toCassandraOpts cas) logger let bhEnv = BHEnv @@ -100,8 +100,7 @@ runSem esConn cas galleyEndpoint logger action = do { conn = ESConn { indexName = esConn.esIndex, - env = bhEnv, - credentials = mEsCreds + env = bhEnv }, additionalConn = Nothing } From 63afe9303a9f0f4e5c6d05857aafc1bb996ca009 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 19 Aug 2024 17:35:20 +0200 Subject: [PATCH 06/48] Delete leftover code from Brig.Index.Eval --- services/brig/src/Brig/Index/Eval.hs | 34 +--------------------------- 1 file changed, 1 insertion(+), 33 deletions(-) diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 54420e7f899..f07e4297491 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -26,7 +24,6 @@ import Brig.App (initHttpManagerWithTLSConfig, mkIndexEnv) import Brig.Index.Options import Brig.Options import Brig.User.Search.Index -import Cassandra qualified as C import Cassandra.Options import Cassandra.Util (defInitCassandra) import Control.Exception (throwIO) @@ -45,7 +42,7 @@ import Polysemy import Polysemy.Error import Polysemy.TinyLog hiding (Logger) import System.Logger qualified as Log -import System.Logger.Class (Logger, MonadLogger (..)) +import System.Logger.Class (Logger) import Util.Options (initCredentials) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc @@ -226,32 +223,3 @@ newtype ReindexFromAnotherIndexError = ReindexFromAnotherIndexError String deriving (Show) instance Exception ReindexFromAnotherIndexError - --------------------------------------------------------------------------------- --- ReindexIO command monad - -newtype ReindexIO a = ReindexIO (ReaderT C.ClientState IndexIO a) - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadReader C.ClientState, - MonadThrow, - MonadCatch - ) - -runReindexIO :: IndexEnv -> C.ClientState -> ReindexIO a -> IO a -runReindexIO ixe cas (ReindexIO ma) = runIndexIO ixe (runReaderT ma cas) - -instance MonadIndexIO ReindexIO where - liftIndexIO = ReindexIO . ReaderT . const - -instance C.MonadClient ReindexIO where - liftClient ma = ask >>= \e -> C.runClient e ma - localState = local - -instance MonadLogger ReindexIO where - log lvl msg = do - l <- ReindexIO . lift $ asks idxLogger - Log.log l lvl msg From d7322483a440107bc4442e641ecad546f51c8824 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Aug 2024 08:35:51 +0200 Subject: [PATCH 07/48] Move UserDoc tests to subsystem Delete test for indexToDoc because it was only used in the test --- .../src/Wire/UserSearch/Types.hs | 4 +- .../test/unit/Wire/UserSearch/TypesSpec.hs | 57 +++++++++++++ services/brig/brig.cabal | 1 - services/brig/test/unit/Run.hs | 4 +- .../unit/Test/Brig/User/Search/Index/Types.hs | 84 ------------------- 5 files changed, 61 insertions(+), 89 deletions(-) create mode 100644 libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs delete mode 100644 services/brig/test/unit/Test/Brig/User/Search/Index/Types.hs diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs index a6aad6f74a1..74fd9eaa79e 100644 --- a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs +++ b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs @@ -18,6 +18,7 @@ import Wire.API.Team.Feature import Wire.API.Team.Role import Wire.API.User import Wire.API.User.Search +import Wire.Arbitrary newtype IndexVersion = IndexVersion {docVersion :: DocVersion} @@ -57,7 +58,8 @@ data UserDoc = UserDoc udSso :: Maybe Sso, udEmailUnvalidated :: Maybe EmailAddress } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserDoc) -- Note: Keep this compatible with the FromJSON instances -- of 'Contact' and 'TeamContact' from 'Wire.API.User.Search diff --git a/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs new file mode 100644 index 00000000000..6309b457438 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs @@ -0,0 +1,57 @@ +module Wire.UserSearch.TypesSpec where + +import Control.Error (hush) +import Data.Aeson as Aeson +import Data.Fixed +import Data.Handle +import Data.Id +import Data.Json.Util +import Data.Time +import Data.Time.Clock.POSIX +import Imports +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.API.Team.Role +import Wire.API.User +import Wire.UserSearch.Types + +spec :: Spec +spec = describe "UserDoc" $ do + describe "JSON" $ do + prop "roundrip to/fromJSON" $ \(userDoc :: UserDoc) -> + fromJSON (toJSON userDoc) === Aeson.Success userDoc + + it "should be backwards comptibile" $ do + eitherDecode (userDoc1ByteString) `shouldBe` Right userDoc1 + +mkTime :: Int -> UTCTime +mkTime = posixSecondsToUTCTime . secondsToNominalDiffTime . MkFixed . (* 1000000000) . fromIntegral + +userDoc1 :: UserDoc +userDoc1 = + UserDoc + { udId = fromJust . hush . parseIdFromText $ "0a96b396-57d6-11ea-a04b-7b93d1a5c19c", + udTeam = hush . parseIdFromText $ "17c59b18-57d6-11ea-9220-8bbf5eee961a", + udName = Just . Name $ "Carl Phoomp", + udNormalized = Just $ "carl phoomp", + udHandle = Just . fromJust . parseHandle $ "phoompy", + udEmail = Just $ Email "phoompy" "example.com", + udColourId = Just . ColourId $ 32, + udAccountStatus = Just Active, + udSAMLIdP = Just "https://issuer.net/214234", + udManagedBy = Just ManagedByScim, + udCreatedAt = Just (toUTCTimeMillis (mkTime 1598737800000)), + udRole = Just RoleAdmin, + udSearchVisibilityInbound = Nothing, + udScimExternalId = Nothing, + udSso = Nothing, + udEmailUnvalidated = Nothing + } + +-- Dont touch this. This represents serialized legacy data. +userDoc1ByteString :: LByteString +userDoc1ByteString = "{\"email\":\"phoompy@example.com\",\"account_status\":\"active\",\"handle\":\"phoompy\",\"managed_by\":\"scim\",\"role\":\"admin\",\"accent_id\":32,\"name\":\"Carl Phoomp\",\"created_at\":\"2020-08-29T21:50:00.000Z\",\"team\":\"17c59b18-57d6-11ea-9220-8bbf5eee961a\",\"id\":\"0a96b396-57d6-11ea-a04b-7b93d1a5c19c\",\"normalized\":\"carl phoomp\",\"saml_idp\":\"https://issuer.net/214234\"}" + +-- indexUser1 :: IndexUser +-- indexUser1 = docToIndex userDoc1 diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 9ecf49e3f91..54c50ea2db4 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -519,7 +519,6 @@ test-suite brig-tests Test.Brig.Effects.Delay Test.Brig.InternalNotification Test.Brig.MLS - Test.Brig.User.Search.Index.Types hs-source-dirs: test/unit ghc-options: -funbox-strict-fields -threaded -with-rtsopts=-N diff --git a/services/brig/test/unit/Run.hs b/services/brig/test/unit/Run.hs index 6d658acb536..a371d3130cc 100644 --- a/services/brig/test/unit/Run.hs +++ b/services/brig/test/unit/Run.hs @@ -25,7 +25,6 @@ import Test.Brig.Calling qualified import Test.Brig.Calling.Internal qualified import Test.Brig.InternalNotification qualified import Test.Brig.MLS qualified -import Test.Brig.User.Search.Index.Types qualified import Test.Tasty main :: IO () @@ -33,8 +32,7 @@ main = defaultMain $ testGroup "Tests" - [ Test.Brig.User.Search.Index.Types.tests, - Test.Brig.Calling.tests, + [ Test.Brig.Calling.tests, Test.Brig.Calling.Internal.tests, Test.Brig.MLS.tests, Test.Brig.InternalNotification.tests diff --git a/services/brig/test/unit/Test/Brig/User/Search/Index/Types.hs b/services/brig/test/unit/Test/Brig/User/Search/Index/Types.hs deleted file mode 100644 index 5e6af3a3d0d..00000000000 --- a/services/brig/test/unit/Test/Brig/User/Search/Index/Types.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Brig.User.Search.Index.Types where - -import Brig.User.Search.Index -import Data.Aeson -import Data.Fixed -import Data.Handle -import Data.Id -import Data.Json.Util -import Data.Time.Clock -import Data.Time.Clock.POSIX -import Data.UUID -import Imports -import Test.Tasty -import Test.Tasty.HUnit -import Wire.API.Team.Role -import Wire.API.User - -tests :: TestTree -tests = - testGroup - "UserDoc, IndexUser: conversion, serialization" - [ testCase "aeson roundtrip: UserDoc" $ - assertEqual - "failed" - (eitherDecode' (encode userDoc1)) - (Right userDoc1), - testCase "backwards comptibility test: UserDoc" $ - assertBool "failed" (isRight (eitherDecode' userDoc1ByteString :: Either String UserDoc)), - testCase "IndexUser to UserDoc" $ - assertEqual - "failed" - (indexToDoc indexUser1) - userDoc1 - ] - -mkTime :: Int -> UTCTime -mkTime = posixSecondsToUTCTime . secondsToNominalDiffTime . MkFixed . (* 1000000000) . fromIntegral - -userDoc1 :: UserDoc -userDoc1 = - UserDoc - { udId = Id . fromJust . fromText $ "0a96b396-57d6-11ea-a04b-7b93d1a5c19c", - udTeam = Just . Id . fromJust . fromText $ "17c59b18-57d6-11ea-9220-8bbf5eee961a", - udName = Just . Name $ "Carl Phoomp", - udNormalized = Just $ "carl phoomp", - udHandle = Just . fromJust . parseHandle $ "phoompy", - udEmail = Just $ unsafeEmailAddress "phoompy" "example.com", - udColourId = Just . ColourId $ 32, - udAccountStatus = Just Active, - udSAMLIdP = Just "https://issuer.net/214234", - udManagedBy = Just ManagedByScim, - udCreatedAt = Just (toUTCTimeMillis (mkTime 1598737800000)), - udRole = Just RoleAdmin, - udSearchVisibilityInbound = Nothing, - udScimExternalId = Nothing, - udSso = Nothing, - udEmailUnvalidated = Nothing - } - --- Dont touch this. This represents serialized legacy data. -userDoc1ByteString :: LByteString -userDoc1ByteString = "{\"email\":\"phoompy@example.com\",\"account_status\":\"active\",\"handle\":\"phoompy\",\"managed_by\":\"scim\",\"role\":\"admin\",\"accent_id\":32,\"name\":\"Carl Phoomp\",\"created_at\":\"2020-08-29T21:50:00.000Z\",\"team\":\"17c59b18-57d6-11ea-9220-8bbf5eee961a\",\"id\":\"0a96b396-57d6-11ea-a04b-7b93d1a5c19c\",\"normalized\":\"carl phoomp\",\"saml_idp\":\"https://issuer.net/214234\"}" - -indexUser1 :: IndexUser -indexUser1 = docToIndex userDoc1 From e46d019343d51017b532f6d3b1a1a8724ed07c8e Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Aug 2024 12:01:41 +0200 Subject: [PATCH 08/48] indexUserRow -> indexUser --- .../Wire/UserSearchSubsystem/Interpreter.hs | 8 ++-- .../src/Wire/UserStore/IndexUser.hs | 41 +++++++------------ 2 files changed, 19 insertions(+), 30 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index ed3b8ac6057..13b208cbea2 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -86,8 +86,8 @@ syncUserImpl uid = (pure defaultSearchVisibilityInbound) teamSearchVisibilityInbound indexUser.teamId - let userDoc = indexUserRowToDoc vis indexUser - version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserRowToVersion indexUser + let userDoc = indexUserToDoc vis indexUser + version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserToVersion indexUser Metrics.incCounter indexUpdateCounter IndexedUserStore.upsert (docId uid) userDoc version @@ -141,8 +141,8 @@ syncAllUsersWithVersion mkVersion = visMap <- fmap Map.fromList . unsafePooledForConcurrentlyN 16 (Set.fromList $ mapMaybe (.teamId) page) $ \t -> (t,) <$> teamSearchVisibilityInbound t let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ flip Map.lookup visMap =<< indexUser.teamId - mkUserDoc indexUser = indexUserRowToDoc (vis indexUser) indexUser - mkDocVersion = mkVersion . ES.ExternalDocVersion . docVersion . indexUserRowToVersion + mkUserDoc indexUser = indexUserToDoc (vis indexUser) indexUser + mkDocVersion = mkVersion . ES.ExternalDocVersion . docVersion . indexUserToVersion pure $ map (\u -> (docId u.userId, mkUserDoc u, mkDocVersion u)) page updateTeamSearchVisibilityInboundImpl :: (Member IndexedUserStore r) => TeamStatus SearchVisibilityInboundConfig -> Sem r () diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index 1809ca3ca89..89df5ec571d 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -38,34 +38,23 @@ data IndexUser = IndexUser unverifiedEmail :: Maybe (WithWritetime EmailAddress) } +{- ORMOLU_DISABLE -} type instance TupleType IndexUser = ( UserId, Maybe TeamId, - Name, - Writetime Name, - Maybe AccountStatus, - Maybe (Writetime AccountStatus), - Maybe Handle, - Maybe (Writetime Handle), - Maybe Email, - Maybe (Writetime Email), - ColourId, - Writetime ColourId, - Activated, - Writetime Activated, - Maybe ServiceId, - Maybe (Writetime ServiceId), - Maybe ManagedBy, - Maybe (Writetime ManagedBy), - Maybe UserSSOId, - Maybe (Writetime UserSSOId), - Maybe Email, - Maybe (Writetime Email) + Name, Writetime Name, + Maybe AccountStatus, Maybe (Writetime AccountStatus), + Maybe Handle, Maybe (Writetime Handle), + Maybe Email, Maybe (Writetime Email), + ColourId, Writetime ColourId, + Activated, Writetime Activated, + Maybe ServiceId, Maybe (Writetime ServiceId), + Maybe ManagedBy, Maybe (Writetime ManagedBy), + Maybe UserSSOId, Maybe (Writetime UserSSOId), + Maybe Email, Maybe (Writetime Email) ) -{- ORMOLU_DISABLE -} - instance Record IndexUser where asTuple (IndexUser {..}) = ( userId, teamId, @@ -109,8 +98,8 @@ instance Record IndexUser where } {- ORMOLU_ENABLE -} -indexUserRowToVersion :: IndexUser -> IndexVersion -indexUserRowToVersion IndexUser {..} = +indexUserToVersion :: IndexUser -> IndexVersion +indexUserToVersion IndexUser {..} = mkIndexVersion [ const () <$$> Just name.writetime, const () <$$> fmap writetime accountStatus, @@ -124,8 +113,8 @@ indexUserRowToVersion IndexUser {..} = const () <$$> fmap writetime unverifiedEmail ] -indexUserRowToDoc :: SearchVisibilityInbound -> IndexUser -> UserDoc -indexUserRowToDoc searchVisInbound IndexUser {..} = +indexUserToDoc :: SearchVisibilityInbound -> IndexUser -> UserDoc +indexUserToDoc searchVisInbound IndexUser {..} = if shouldIndex then UserDoc From e0c68fae343eadfbc9f223dc2f100d9a4d9d60ff Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Aug 2024 12:02:38 +0200 Subject: [PATCH 09/48] brig: Delete bulk reindex operations from internal API --- .../API/Routes/Internal/Brig/SearchIndex.hs | 18 ------------------ services/brig/src/Brig/API/Internal.hs | 2 -- 2 files changed, 20 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs index 0b90fd43524..9e0fdabd7dc 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/SearchIndex.hs @@ -30,21 +30,3 @@ type ISearchIndexAPI = :> "refresh" :> Post '[JSON] NoContent ) - :<|> Named - "indexReindex" - ( Summary - "reindex from Cassandra (NB: e.g. integration testing prefer the `brig-index` \ - \executable for actual operations!)" - :> "index" - :> "reindex" - :> Post '[JSON] NoContent - ) - :<|> Named - "indexReindexIfSameOrNewer" - ( Summary - "forcefully reindex from Cassandra, even if nothing has changed (NB: e.g. \ - \integration testing prefer the `brig-index` executable for actual operations!)" - :> "index" - :> "reindex-if-same-or-newer" - :> Post '[JSON] NoContent - ) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 500510dc9bf..9ea3e4a6161 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -391,8 +391,6 @@ getVerificationCode uid action = runMaybeT do internalSearchIndexAPI :: forall r. ServerT BrigIRoutes.ISearchIndexAPI (Handler r) internalSearchIndexAPI = Named @"indexRefresh" (NoContent <$ lift (wrapClient Search.refreshIndex)) - :<|> Named @"indexReindex" (NoContent <$ lift (wrapClient Search.reindexAll)) - :<|> Named @"indexReindexIfSameOrNewer" (NoContent <$ lift (wrapClient Search.reindexAllIfSameOrNewer)) --------------------------------------------------------------------------- -- Handlers From d0272dfeac6509c3c2ed2d85139f85b1a2d6cbf2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Aug 2024 12:22:46 +0200 Subject: [PATCH 10/48] brig: Use the UserSearchSubsystem for syncing with index Query operations are still pending --- libs/brig-types/brig-types.cabal | 1 - libs/brig-types/src/Brig/Types/Search.hs | 43 --------------- .../Wire/IndexedUserStore/ElasticSearch.hs | 20 +++---- .../src/Wire/UserSearch/Types.hs | 2 + .../src/Wire/UserStore/IndexUser.hs | 8 +-- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/src/Brig/API/Auth.hs | 19 ++++--- services/brig/src/Brig/API/Client.hs | 13 +++-- services/brig/src/Brig/API/Internal.hs | 47 +++++++++++------ services/brig/src/Brig/API/Public.hs | 28 ++++++---- services/brig/src/Brig/API/User.hs | 52 +++++++++++++------ services/brig/src/Brig/App.hs | 1 + .../brig/src/Brig/CanonicalInterpreter.hs | 28 ++++++++++ services/brig/src/Brig/IO/Intra.hs | 25 +++++---- .../brig/src/Brig/InternalEvent/Process.hs | 4 +- services/brig/src/Brig/Team/API.hs | 10 ++-- services/brig/src/Brig/User/API/Search.hs | 6 +-- services/brig/src/Brig/User/Auth.hs | 19 ++++--- services/brig/src/Brig/User/Search/Index.hs | 18 ++----- .../brig/src/Brig/User/Search/SearchIndex.hs | 11 ++-- .../brig/src/Brig/User/Search/TeamSize.hs | 2 + .../src/Brig/User/Search/TeamUserSearch.hs | 4 ++ 22 files changed, 206 insertions(+), 156 deletions(-) delete mode 100644 libs/brig-types/src/Brig/Types/Search.hs diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 3f19b147eab..161a81ce30c 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -17,7 +17,6 @@ library Brig.Types.Instances Brig.Types.Intra Brig.Types.Provider.Tag - Brig.Types.Search Brig.Types.Team Brig.Types.Team.LegalHold Brig.Types.Test.Arbitrary diff --git a/libs/brig-types/src/Brig/Types/Search.hs b/libs/brig-types/src/Brig/Types/Search.hs deleted file mode 100644 index 4ebc32ab2c6..00000000000 --- a/libs/brig-types/src/Brig/Types/Search.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE StrictData #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.Search - ( TeamSearchInfo (..), - ) -where - -import Data.Id (TeamId) - --- | Outbound search restrictions configured by team admin of the searcher. This --- value restricts the set of user that are searched. --- --- See 'optionallySearchWithinTeam' for the effect on full-text search. --- --- See 'mkTeamSearchInfo' for the business logic that defines the TeamSearchInfo --- value. --- --- Search results might be affected by the inbound search restriction settings of --- the searched user. ('SearchVisibilityInbound') -data TeamSearchInfo - = -- | Only users that are not part of any team are searched - NoTeam - | -- | Only users from the same team as the searcher are searched - TeamOnly TeamId - | -- | No search restrictions, all users are searched - AllUsers diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index 4c99b32e8ee..d2f59c0fc62 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -1,5 +1,6 @@ module Wire.IndexedUserStore.ElasticSearch where +import Control.Exception (throwIO) import Data.Aeson import Data.Aeson.Key qualified as Key import Data.ByteString.Builder @@ -12,7 +13,6 @@ import Imports import Network.HTTP.Client import Network.HTTP.Types import Polysemy -import Polysemy.Error import Wire.IndexedUserStore import Wire.Sem.Metrics (Metrics) import Wire.Sem.Metrics qualified as Metrics @@ -39,7 +39,6 @@ instance Exception IndexedUserStoreError interpretIndexedUserStoreES :: ( Member (Embed IO) r, - Member (Error IndexedUserStoreError) r, Member Metrics r ) => IndexedUserStoreConfig -> @@ -54,7 +53,6 @@ interpretIndexedUserStoreES cfg = upsertImpl :: forall r. ( Member (Embed IO) r, - Member (Error IndexedUserStoreError) r, Member Metrics r ) => IndexedUserStoreConfig -> @@ -71,12 +69,12 @@ upsertImpl cfg docId userDoc versioning = do unless (ES.isSuccess r || ES.isVersionConflict r) $ do lift $ Metrics.incCounter indexUpdateErrorCounter res <- liftIO $ ES.parseEsResponse r - lift . throw . IndexUpdateError . either id id $ res + liftIO . throwIO . IndexUpdateError . either id id $ res lift $ Metrics.incCounter indexUpdateSuccessCounter settings = ES.defaultIndexDocumentSettings {ES.idsVersionControl = versioning} -updateTeamSearchVisibilityInboundImpl :: forall r. (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> TeamId -> SearchVisibilityInbound -> Sem r () +updateTeamSearchVisibilityInboundImpl :: forall r. (Member (Embed IO) r) => IndexedUserStoreConfig -> TeamId -> SearchVisibilityInbound -> Sem r () updateTeamSearchVisibilityInboundImpl cfg tid vis = void $ runInBothES cfg updateAllDocs where @@ -85,7 +83,7 @@ updateTeamSearchVisibilityInboundImpl cfg tid vis = r <- ES.updateByQuery idx query (Just script) unless (ES.isSuccess r || ES.isVersionConflict r) $ do res <- liftIO $ ES.parseEsResponse r - lift . throw . IndexUpdateError . either id id $ res + liftIO . throwIO . IndexUpdateError . either id id $ res query :: ES.Query query = ES.TermQuery (ES.Term "team" $ idToText tid) Nothing @@ -101,13 +99,7 @@ updateTeamSearchVisibilityInboundImpl cfg tid vis = <> Text.decodeUtf8 (toByteString' vis) <> "';" -bulkUpsertImpl :: - ( Member (Embed IO) r, - Member (Error IndexedUserStoreError) r - ) => - IndexedUserStoreConfig -> - [(ES.DocId, UserDoc, ES.VersionControl)] -> - Sem r () +bulkUpsertImpl :: (Member (Embed IO) r) => IndexedUserStoreConfig -> [(ES.DocId, UserDoc, ES.VersionControl)] -> Sem r () bulkUpsertImpl cfg docs = do let bhe = cfg.conn.env ES.IndexName idx = cfg.conn.indexName @@ -124,7 +116,7 @@ bulkUpsertImpl cfg docs = do res <- embed $ httpLbs req (ES.bhManager bhe) unless (ES.isSuccess res) $ do parsedRes <- liftIO $ ES.parseEsResponse res - throw . IndexUpdateError . either id id $ parsedRes + liftIO . throwIO . IndexUpdateError . either id id $ parsedRes where encodeJSONToString :: (ToJSON a) => a -> Builder encodeJSONToString = fromEncoding . toEncoding diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs index 74fd9eaa79e..7761def2b90 100644 --- a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs +++ b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs @@ -174,3 +174,5 @@ instance FromJSON SearchVisibilityInbound where case runParser (parser @SearchVisibilityInbound) (encodeUtf8 str) of Left err -> fail err Right result -> pure result + +data IndexQuery r = IndexQuery Query Filter [DefaultSort] diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index 89df5ec571d..9209e6e603c 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -169,10 +169,10 @@ indexUserToDoc searchVisInbound IndexUser {..} = (issuer, nameid) <- ssoIssuerAndNameId userSsoId pure $ Sso {ssoIssuer = issuer, ssoNameId = nameid} - -- Transliteration could also be done by ElasticSearch (ICU plugin), but this would - -- require a data migration. - normalized :: Text -> Text - normalized = transliterate (trans "Any-Latin; Latin-ASCII; Lower") +-- Transliteration could also be done by ElasticSearch (ICU plugin), but this would +-- require a data migration. +normalized :: Text -> Text +normalized = transliterate (trans "Any-Latin; Latin-ASCII; Lower") emptyUserDoc :: UserId -> UserDoc emptyUserDoc uid = diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 3ee68eac707..0c8a7a1979a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -241,6 +241,7 @@ test-suite wire-subsystems-tests Wire.MockInterpreters.VerificationCodeStore Wire.NotificationSubsystem.InterpreterSpec Wire.PropertySubsystem.InterpreterSpec + Wire.UserSearch.TypesSpec Wire.UserStoreSpec Wire.UserSubsystem.InterpreterSpec Wire.VerificationCodeSubsystem.InterpreterSpec diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index cb167140ffb..fce4e8a6919 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -59,6 +59,7 @@ import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserStore import Wire.UserSubsystem import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) @@ -69,7 +70,8 @@ accessH :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => Maybe ClientId -> [Either Text SomeUserToken] -> @@ -88,7 +90,8 @@ access :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => Maybe ClientId -> NonEmpty (Token u) -> @@ -114,7 +117,8 @@ login :: Member PasswordStore r, Member UserKeyStore r, Member UserStore r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member UserSearchSubsystem r ) => Login -> Maybe Bool -> @@ -141,7 +145,8 @@ logout uts (Just at) = Auth.logout (List1 uts) at !>> zauthError changeSelfEmailH :: ( Member BlockListStore r, Member UserKeyStore r, - Member EmailSubsystem r + Member EmailSubsystem r, + Member UserSearchSubsystem r ) => [Either Text SomeUserToken] -> Maybe (Either Text SomeAccessToken) -> @@ -180,7 +185,8 @@ legalHoldLogin :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => LegalHoldLogin -> Handler r SomeAccess @@ -195,7 +201,8 @@ ssoLogin :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => SsoLogin -> Maybe Bool -> diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index eecc682427b..e30c0441fdf 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -115,6 +115,7 @@ import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) import Wire.Sem.Now as Now import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) @@ -170,7 +171,8 @@ addClient :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member UserSearchSubsystem r ) => UserId -> Maybe ConnId -> @@ -191,7 +193,8 @@ addClientWithReAuthPolicy :: Member DeleteQueue r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member UserSearchSubsystem r ) => Data.ReAuthPolicy -> UserId -> @@ -519,7 +522,8 @@ legalHoldClientRequested :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> LegalHoldClientRequest -> @@ -541,7 +545,8 @@ removeLegalHoldClient :: Member (Input (Local ())) r, Member DeleteQueue r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> AppT r () diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 9ea3e4a6161..2c9f96a564d 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -57,7 +57,6 @@ import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User import Brig.User.API.Search qualified as Search import Brig.User.EJPD qualified -import Brig.User.Search.Index qualified as Index import Control.Error hiding (bool) import Control.Lens (preview, to, view, _Just) import Data.ByteString.Conversion (toByteString) @@ -110,6 +109,7 @@ import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearchSubsystem (UserSearchSubsystem, updateTeamSearchVisibilityInbound) import Wire.UserStore import Wire.UserSubsystem import Wire.UserSubsystem qualified as UserSubsystem @@ -139,7 +139,8 @@ servantSitemap :: Member EmailSending r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -190,7 +191,8 @@ accountAPI :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -242,11 +244,12 @@ teamsAPI :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSending r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserSearchSubsystem r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = - Named @"updateSearchVisibilityInbound" Index.updateSearchVisibilityInbound + Named @"updateSearchVisibilityInbound" (lift . liftSem . updateTeamSearchVisibilityInbound) :<|> Named @"get-invitation-by-email" Team.getInvitationByEmail :<|> Named @"get-invitation-code" Team.getInvitationCode :<|> Named @"suspend-team" Team.suspendTeam @@ -271,7 +274,8 @@ authAPI :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member UserSearchSubsystem r ) => ServerT BrigIRoutes.AuthAPI (Handler r) authAPI = @@ -406,7 +410,8 @@ addClientInternalH :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member UserSearchSubsystem r ) => UserId -> Maybe Bool -> @@ -425,7 +430,8 @@ legalHoldClientRequestedH :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> LegalHoldClientRequest -> @@ -440,7 +446,8 @@ removeLegalHoldClientH :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> (Handler r) NoContent @@ -466,7 +473,8 @@ createUserNoVerify :: Member UserKeyStore r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => NewUser -> (Handler r) (Either RegisterError SelfProfile) @@ -490,7 +498,8 @@ createUserNoVerifySpar :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) @@ -516,7 +525,8 @@ deleteUserNoAuthH :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => UserId -> (Handler r) DeleteUserResponse @@ -527,14 +537,14 @@ deleteUserNoAuthH uid = do AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted AccountDeleted -> pure UserResponseAccountDeleted -changeSelfEmailMaybeSendH :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> EmailUpdate -> Maybe Bool -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSendH :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, Member UserSearchSubsystem r) => UserId -> EmailUpdate -> Maybe Bool -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSendH u body (fromMaybe False -> validate) = do let email = euEmail body changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email UpdateOriginScim data MaybeSendEmail = ActuallySendEmail | DoNotSendEmail -changeSelfEmailMaybeSend :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> MaybeSendEmail -> EmailAddress -> UpdateOriginType -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSend :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, Member UserSearchSubsystem r) => UserId -> MaybeSendEmail -> EmailAddress -> UpdateOriginType -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSend u ActuallySendEmail email allowScim = do API.changeSelfEmail u email allowScim changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do @@ -632,7 +642,8 @@ changeAccountStatusH :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> AccountStatusUpdate -> @@ -709,7 +720,8 @@ updateSSOIdH :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> UserSSOId -> @@ -728,7 +740,8 @@ deleteSSOIdH :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> (Handler r) UpdateSSOIdResponse diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index dc58cb86e28..60980cb39db 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -160,6 +160,7 @@ import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserStore (UserStore) import Wire.UserSubsystem hiding (checkHandle, checkHandles) import Wire.UserSubsystem qualified as UserSubsystem @@ -285,7 +286,8 @@ servantSitemap :: Member EmailSubsystem r, Member EmailSending r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -559,7 +561,8 @@ addClient :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member UserSearchSubsystem r ) => UserId -> ConnId -> @@ -690,7 +693,8 @@ createUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, - Member EmailSending r + Member EmailSending r, + Member UserSearchSubsystem r ) => Public.NewUserPublic -> Handler r (Either Public.RegisterError Public.RegisterSuccess) @@ -911,7 +915,8 @@ removeEmail :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserSearchSubsystem r ) => UserId -> Handler r (Maybe Public.RemoveIdentityError) @@ -1173,7 +1178,8 @@ deleteSelfUser :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => UserId -> Public.DeleteUser -> @@ -1191,7 +1197,8 @@ verifyDeleteUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => Public.VerifyDeleteUser -> Handler r () @@ -1202,7 +1209,8 @@ updateUserEmail :: ( Member BlockListStore r, Member UserKeyStore r, Member GalleyAPIAccess r, - Member EmailSubsystem r + Member EmailSubsystem r, + Member UserSearchSubsystem r ) => UserId -> UserId -> @@ -1237,7 +1245,8 @@ activate :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => Public.ActivationKey -> Public.ActivationCode -> @@ -1254,7 +1263,8 @@ activateKey :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => Public.Activate -> (Handler r) ActivationRespWithStatus diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index fd9787edcd3..410f98b8cf1 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -92,7 +92,6 @@ import Brig.Team.DB qualified as Team import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra import Brig.User.Auth.Cookie qualified as Auth -import Brig.User.Search.Index (reindex) import Brig.User.Search.TeamSize qualified as TeamSize import Cassandra hiding (Set) import Control.Error @@ -149,6 +148,8 @@ import Wire.PropertySubsystem as PropertySubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearchSubsystem (UserSearchSubsystem) +import Wire.UserSearchSubsystem qualified as UserSearchSubsystem import Wire.UserStore import Wire.UserSubsystem as User import Wire.UserSubsystem.HandleBlacklist @@ -198,7 +199,8 @@ createUserSpar :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member UserSubsystem r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult @@ -270,7 +272,8 @@ createUser :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -526,7 +529,16 @@ checkRestrictedUserCreation new = do -- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send -- validation email. -changeSelfEmail :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> EmailAddress -> UpdateOriginType -> ExceptT HttpError (AppT r) ChangeEmailResponse +changeSelfEmail :: + ( Member BlockListStore r, + Member UserKeyStore r, + Member EmailSubsystem r, + Member UserSearchSubsystem r + ) => + UserId -> + EmailAddress -> + UpdateOriginType -> + ExceptT HttpError (AppT r) ChangeEmailResponse changeSelfEmail u email allowScim = do changeEmail u email allowScim !>> Error.changeEmailError >>= \case ChangeEmailIdempotent -> @@ -534,7 +546,7 @@ changeSelfEmail u email allowScim = do ChangeEmailNeedsActivation (usr, adata, en) -> lift $ do liftSem $ sendOutEmail usr adata en wrapClient $ Data.updateEmailUnvalidated u email - wrapClient $ reindex u + liftSem $ UserSearchSubsystem.syncUser u pure ChangeEmailResponseNeedsActivation where sendOutEmail usr adata en = do @@ -578,7 +590,8 @@ removeEmail :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserSearchSubsystem r ) => UserId -> ExceptT RemoveIdentityError (AppT r) () @@ -622,7 +635,8 @@ changeAccountStatus :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => List1 UserId -> AccountStatus -> @@ -645,7 +659,8 @@ changeSingleAccountStatus :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> AccountStatus -> @@ -678,7 +693,8 @@ activate :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => ActivationTarget -> ActivationCode -> @@ -694,7 +710,8 @@ activateWithCurrency :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => ActivationTarget -> ActivationCode -> @@ -741,7 +758,8 @@ onActivated :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => ActivationEvent -> AppT r (UserId, Maybe UserIdentity, Bool) @@ -871,7 +889,8 @@ deleteSelfUser :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => UserId -> Maybe PlainTextPassword6 -> @@ -943,7 +962,8 @@ verifyDeleteUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => VerifyDeleteUser -> ExceptT DeleteUserError (AppT r) () @@ -970,7 +990,8 @@ ensureAccountDeleted :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member UserStore r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => UserId -> AppT r DeleteUserResult @@ -1020,7 +1041,8 @@ deleteAccount :: Member UserStore r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => UserAccount -> Sem r () diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 1df8edefd8e..5d64f507869 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -39,6 +39,7 @@ module Brig.App cargoholdEndpoint, federator, casClient, + indexEnv, userTemplates, providerTemplates, teamTemplates, diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index ca597c1063a..e7db04ec321 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -15,6 +15,7 @@ import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationS import Brig.IO.Intra (runEvents) import Brig.Options (ImplicitNoFederationRestriction (federationDomainConfig), federationDomainConfigs, federationStrategy) import Brig.Options qualified as Opt +import Brig.User.Search.Index (IndexEnv (..)) import Cassandra qualified as Cas import Control.Exception (ErrorCall) import Control.Lens (to, (^.)) @@ -50,6 +51,8 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.GundeckAPIAccess import Wire.HashPassword +import Wire.IndexedUserStore +import Wire.IndexedUserStore.ElasticSearch import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) import Wire.ParseException @@ -67,6 +70,8 @@ import Wire.Sem.Concurrency.IO import Wire.Sem.Delay import Wire.Sem.Jwk import Wire.Sem.Logger.TinyLog (loggerToTinyLogReqId) +import Wire.Sem.Metrics +import Wire.Sem.Metrics.IO (runMetricsToIO) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) @@ -76,6 +81,8 @@ import Wire.SessionStore import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) import Wire.UserKeyStore import Wire.UserKeyStore.Cassandra +import Wire.UserSearchSubsystem +import Wire.UserSearchSubsystem.Interpreter (interpretUserSearchSubsystem) import Wire.UserStore import Wire.UserStore.Cassandra import Wire.UserSubsystem @@ -94,6 +101,7 @@ type BrigCanonicalEffects = PropertySubsystem, DeleteQueue, Wire.Events.Events, + UserSearchSubsystem, Error UserSubsystemError, Error AuthenticationSubsystemError, Error Wire.API.Federation.Error.FederationError, @@ -104,6 +112,7 @@ type BrigCanonicalEffects = HashPassword, UserKeyStore, UserStore, + IndexedUserStore, SessionStore, PasswordStore, VerificationCodeStore, @@ -129,6 +138,7 @@ type BrigCanonicalEffects = GalleyAPIAccess, EmailSending, Rpc, + Metrics, Embed Cas.Client, Error ParseException, Error ErrorCall, @@ -162,6 +172,21 @@ runBrigToIO e (AppT ma) = do maxValueLength = fromMaybe Opt.defMaxValueLen $ e ^. settings . Opt.propertyMaxValueLen, maxProperties = 16 } + mainESEnv = e ^. App.indexEnv . to idxElastic + indexedUserStoreConfig = + IndexedUserStoreConfig + { conn = + ESConn + { env = mainESEnv, + indexName = e ^. App.indexEnv . to idxName + }, + additionalConn = + (e ^. App.indexEnv . to idxAdditionalName) <&> \additionalIndexName -> + ESConn + { env = e ^. App.indexEnv . to idxAdditionalElastic . to (fromMaybe mainESEnv), + indexName = additionalIndexName + } + } ( either throwM pure <=< ( runFinal . unsafelyPerformConcurrency @@ -174,6 +199,7 @@ runBrigToIO e (AppT ma) = do . mapError @ErrorCall SomeException . mapError @ParseException SomeException . interpretClientToIO (e ^. casClient) + . runMetricsToIO . runRpcWithHttp (e ^. httpManager) (e ^. App.requestId) . emailSendingInterpreter e . interpretGalleyAPIAccessToRpc (e ^. disabledVersions) (e ^. galleyEndpoint) @@ -199,6 +225,7 @@ runBrigToIO e (AppT ma) = do . interpretVerificationCodeStoreCassandra (e ^. casClient) . interpretPasswordStore (e ^. casClient) . interpretSessionStoreCassandra (e ^. casClient) + . interpretIndexedUserStoreES indexedUserStoreConfig . interpretUserStoreCassandra (e ^. casClient) . interpretUserKeyStoreCassandra (e ^. casClient) . runHashPassword @@ -209,6 +236,7 @@ runBrigToIO e (AppT ma) = do . mapError (StdError . federationErrorToWai) . mapError authenticationSubsystemErrorToHttpError . mapError userSubsystemErrorToHttpError + . interpretUserSearchSubsystem . runEvents . runDeleteQueue (e ^. internalEvents) . interpretPropertySubsystem propertySubsystemConfig diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 716272ccf62..9d3e61d9ecb 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -61,7 +61,6 @@ import Brig.Federation.Client (notifyUserDeleted, sendConnectionAction) import Brig.IO.Journal qualified as Journal import Brig.IO.Logging import Brig.RPC -import Brig.User.Search.Index qualified as Search import Control.Error (ExceptT, runExceptT) import Control.Lens (view, (.~), (?~), (^.), (^?)) import Control.Monad.Catch @@ -105,6 +104,8 @@ import Wire.Rpc import Wire.Sem.Logger qualified as Log import Wire.Sem.Paging qualified as P import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserSearchSubsystem (UserSearchSubsystem) +import Wire.UserSearchSubsystem qualified as UserSearchSubsystem ----------------------------------------------------------------------------- -- Event Handlers @@ -115,7 +116,8 @@ onUserEvent :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> Maybe ConnId -> @@ -132,7 +134,8 @@ runEvents :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => InterpreterFor Events r runEvents = interpret \case @@ -193,23 +196,23 @@ onClientEvent orig conn e = do ] updateSearchIndex :: - (Member (Embed HttpClientIO) r) => + (Member UserSearchSubsystem r) => UserId -> UserEvent -> Sem r () -updateSearchIndex orig e = embed $ case e of +updateSearchIndex orig e = case e of -- no-ops UserCreated {} -> pure () UserIdentityUpdated UserIdentityUpdatedData {..} -> do - when (isJust eiuEmail) $ Search.reindex orig + when (isJust eiuEmail) $ UserSearchSubsystem.syncUser orig UserIdentityRemoved {} -> pure () UserLegalHoldDisabled {} -> pure () UserLegalHoldEnabled {} -> pure () LegalHoldClientRequested {} -> pure () - UserSuspended {} -> Search.reindex orig - UserResumed {} -> Search.reindex orig - UserActivated {} -> Search.reindex orig - UserDeleted {} -> Search.reindex orig + UserSuspended {} -> UserSearchSubsystem.syncUser orig + UserResumed {} -> UserSearchSubsystem.syncUser orig + UserActivated {} -> UserSearchSubsystem.syncUser orig + UserDeleted {} -> UserSearchSubsystem.syncUser orig UserUpdated UserUpdatedData {..} -> do let interesting = or @@ -219,7 +222,7 @@ updateSearchIndex orig e = embed $ case e of isJust eupManagedBy, isJust eupSSOId || eupSSOIdRemoved ] - when interesting $ Search.reindex orig + when interesting $ UserSearchSubsystem.syncUser orig journalEvent :: (MonadReader Env m, MonadIO m) => UserId -> UserEvent -> m () journalEvent orig e = case e of diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 899381faa23..291400fff98 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -43,6 +43,7 @@ import Wire.PropertySubsystem import Wire.Sem.Delay import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserStore (UserStore) -- | Handle an internal event. @@ -59,7 +60,8 @@ onEvent :: Member (Input UTCTime) r, Member UserStore r, Member (ConnectionStore InternalPaging) r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member UserSearchSubsystem r ) => InternalNotification -> Sem r () diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index c208ceb34cd..474ceec58bc 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -84,6 +84,7 @@ import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserSubsystem servantAPI :: @@ -302,7 +303,8 @@ suspendTeam :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => TeamId -> (Handler r) NoContent @@ -321,7 +323,8 @@ unsuspendTeam :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => TeamId -> (Handler r) NoContent @@ -341,7 +344,8 @@ changeTeamAccountStatuses :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => TeamId -> AccountStatus -> diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index afb00c1efd6..94372807f9d 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -19,8 +19,6 @@ module Brig.User.API.Search ( search, teamUserSearch, refreshIndex, - reindexAll, - reindexAllIfSameOrNewer, ) where @@ -33,7 +31,6 @@ import Brig.Effects.FederationConfigStore qualified as E import Brig.Federation.Client qualified as Federation import Brig.Options qualified as Opts import Brig.Team.Util (ensurePermissions, ensurePermissionsOrPersonalUser) -import Brig.Types.Search as Search import Brig.User.API.Handle qualified as HandleAPI import Brig.User.Search.Index import Brig.User.Search.SearchIndex qualified as Q @@ -59,6 +56,7 @@ import Wire.API.User.Search import Wire.API.User.Search qualified as Public import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.UserSearch.Types qualified as Search import Wire.UserStore (UserStore) import Wire.UserSubsystem @@ -152,7 +150,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do handleTeamVisibility _ SearchVisibilityStandard = Search.AllUsers handleTeamVisibility t SearchVisibilityNoNameOutsideTeam = Search.TeamOnly t - mkTeamSearchInfo :: Maybe TeamId -> (Handler r) TeamSearchInfo + mkTeamSearchInfo :: Maybe TeamId -> (Handler r) Search.TeamSearchInfo mkTeamSearchInfo searcherTeamId = lift $ do sameTeamSearchOnly <- fromMaybe False <$> view (settings . Opts.searchSameTeamOnly) case searcherTeamId of diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index b17ff8e6689..1bb322753c3 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -80,6 +80,7 @@ import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserStore import Wire.VerificationCode qualified as VerificationCode import Wire.VerificationCodeGen qualified as VerificationCodeGen @@ -98,7 +99,8 @@ login :: Member PasswordStore r, Member UserKeyStore r, Member UserStore r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member UserSearchSubsystem r ) => Login -> CookieType -> @@ -201,7 +203,8 @@ renewAccess :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> @@ -237,7 +240,8 @@ catchSuspendInactiveUser :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> e -> @@ -266,7 +270,8 @@ newAccess :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => UserId -> Maybe ClientId -> @@ -367,7 +372,8 @@ ssoLogin :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => SsoLogin -> CookieType -> @@ -394,7 +400,8 @@ legalHoldLogin :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSearchSubsystem r ) => LegalHoldLogin -> CookieType -> diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index b9f7c465efd..f307319a381 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -40,38 +40,26 @@ module Brig.User.Search.Index ) where -import Bilge (expect2xx, header, lbytes, paths) import Bilge.IO (MonadHttp) import Bilge.IO qualified as RPC -import Bilge.RPC (RPCException (RPCException)) -import Bilge.Request qualified as RPC (empty, host, method, port) -import Bilge.Response (responseJsonThrow) -import Bilge.Retry (rpcHandlers) import Brig.Index.Types (CreateIndexSettings (..)) import Control.Lens hiding ((#), (.=)) -import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM, try) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM) import Control.Monad.Except -import Control.Retry (RetryPolicy, exponentialBackoff, limitRetries, recovering) import Data.Aeson as Aeson -import Data.ByteString.Lazy qualified as BL import Data.Credentials import Data.Id import Data.Map qualified as Map -import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding -import Data.Text.Lazy qualified as LT import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) import Network.HTTP.Client hiding (host, path, port) -import Network.HTTP.Types (StdMethod (POST), statusCode) +import Network.HTTP.Types (statusCode) import Prometheus (MonadMonitor) -import Prometheus qualified as Prom import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..), field, info, msg, val, (+++), (~~)) -import Util.Options (Endpoint, host, port) -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi -import Wire.API.Team.Feature (SearchVisibilityInboundConfig, featureNameBS) +import Util.Options (Endpoint) import Wire.UserSearch.Types (searchVisibilityInboundFieldName) -------------------------------------------------------------------------------- diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index 82b76637976..e7d44d9d982 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -25,10 +25,10 @@ module Brig.User.Search.SearchIndex where import Brig.App (Env, viewFederationDomain) -import Brig.Types.Search import Brig.User.Search.Index import Control.Lens hiding (setting, (#), (.=)) import Control.Monad.Catch (MonadThrow, throwM) +import Data.Aeson.Key qualified as Key import Data.Domain (Domain) import Data.Handle (Handle (fromHandle)) import Data.Id @@ -37,6 +37,11 @@ import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) import Wire.API.User (ColourId (..), Name (fromName)) import Wire.API.User.Search +-- TODO: importing interpreters here is not ideal, perhaps much of this code +-- will go into the interpreter in following commits. +import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..), mappingName) +import Wire.UserSearch.Types +import Wire.UserStore.IndexUser (normalized) -- | User that is performing the search -- Team of user that is performing the search @@ -186,7 +191,7 @@ termQ f v = matchSelf :: SearchSetting -> Maybe ES.Query matchSelf (FederatedSearch _) = Nothing -matchSelf (LocalSearch searcher _tid _searchInfo) = Just (termQ "_id" (review _TextId searcher)) +matchSelf (LocalSearch searcher _tid _searchInfo) = Just (termQ "_id" (idToText searcher)) -- | See 'TeamSearchInfo' restrictSearchSpace :: SearchSetting -> ES.Query @@ -244,7 +249,7 @@ matchTeamMembersSearchableByAllTeams = boolQuery { ES.boolQueryMustMatch = [ ES.QueryExistsQuery $ ES.FieldName "team", - ES.TermQuery (ES.Term searchVisibilityInboundFieldName "searchable-by-all-teams") Nothing + ES.TermQuery (ES.Term (Key.toText searchVisibilityInboundFieldName) "searchable-by-all-teams") Nothing ] } diff --git a/services/brig/src/Brig/User/Search/TeamSize.hs b/services/brig/src/Brig/User/Search/TeamSize.hs index dce653ab03b..54bf2522a5b 100644 --- a/services/brig/src/Brig/User/Search/TeamSize.hs +++ b/services/brig/src/Brig/User/Search/TeamSize.hs @@ -28,6 +28,8 @@ import Control.Monad.Catch (throwM) import Data.Id import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) +-- TODO: Not ideal to import interpreters +import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..)) teamSize :: (MonadIndexIO m) => TeamId -> m TeamSize teamSize t = liftIndexIO $ do diff --git a/services/brig/src/Brig/User/Search/TeamUserSearch.hs b/services/brig/src/Brig/User/Search/TeamUserSearch.hs index 90bcb969e96..c071094c6da 100644 --- a/services/brig/src/Brig/User/Search/TeamUserSearch.hs +++ b/services/brig/src/Brig/User/Search/TeamUserSearch.hs @@ -40,6 +40,10 @@ import Data.Text.Ascii (decodeBase64Url, encodeBase64Url) import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) import Wire.API.User.Search +-- TODO: importing interpreters is not ideal +import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..), mappingName) +import Wire.UserSearch.Types (IndexQuery (..)) +import Wire.UserStore.IndexUser (normalized) teamUserSearch :: (HasCallStack, MonadIndexIO m) => From 9fab12e6d544d8fd0a907524c617d710e64ef584 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 20 Aug 2024 14:07:15 +0200 Subject: [PATCH 11/48] regen nix --- libs/brig-types/default.nix | 7 ------- libs/polysemy-wire-zoo/default.nix | 2 ++ libs/wire-subsystems/default.nix | 16 ++++++++++++++++ services/brig/default.nix | 3 --- 4 files changed, 18 insertions(+), 10 deletions(-) diff --git a/libs/brig-types/default.nix b/libs/brig-types/default.nix index 50587cd4eeb..290305e7c13 100644 --- a/libs/brig-types/default.nix +++ b/libs/brig-types/default.nix @@ -4,9 +4,7 @@ # dependencies are added or removed. { mkDerivation , aeson -, attoparsec , base -, bytestring , bytestring-conversion , cassandra-util , containers @@ -18,7 +16,6 @@ , tasty , tasty-hunit , tasty-quickcheck -, text , types-common , wire-api }: @@ -27,16 +24,12 @@ mkDerivation { version = "1.35.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - attoparsec base - bytestring bytestring-conversion cassandra-util containers imports QuickCheck - text types-common wire-api ]; diff --git a/libs/polysemy-wire-zoo/default.nix b/libs/polysemy-wire-zoo/default.nix index ebf7e8de8c5..21bf9204774 100644 --- a/libs/polysemy-wire-zoo/default.nix +++ b/libs/polysemy-wire-zoo/default.nix @@ -19,6 +19,7 @@ , polysemy , polysemy-check , polysemy-plugin +, prometheus-client , QuickCheck , saml2-web-sso , time @@ -45,6 +46,7 @@ mkDerivation { polysemy polysemy-check polysemy-plugin + prometheus-client QuickCheck saml2-web-sso time diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 890275b857d..5e8d703bc6a 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -8,12 +8,15 @@ , amazonka-core , amazonka-ses , async +, attoparsec , base , base16-bytestring , bilge +, bloodhound , bytestring , bytestring-conversion , cassandra-util +, conduit , containers , cql , crypton @@ -50,12 +53,15 @@ , polysemy-time , polysemy-wire-zoo , postie +, prometheus-client , QuickCheck , quickcheck-instances , random , resource-pool , resourcet , retry +, saml2-web-sso +, schema-profunctor , scientific , servant , servant-client-core @@ -64,6 +70,7 @@ , string-conversions , template , text +, text-icu-translit , time , time-out , time-units @@ -73,6 +80,7 @@ , types-common , unliftio , unordered-containers +, uri-bytestring , uuid , wai-utilities , wire-api @@ -88,12 +96,15 @@ mkDerivation { amazonka-core amazonka-ses async + attoparsec base base16-bytestring bilge + bloodhound bytestring bytestring-conversion cassandra-util + conduit containers cql crypton @@ -125,15 +136,19 @@ mkDerivation { polysemy-plugin polysemy-time polysemy-wire-zoo + prometheus-client QuickCheck resource-pool resourcet retry + saml2-web-sso + schema-profunctor servant servant-client-core stomp-queue template text + text-icu-translit time time-out time-units @@ -143,6 +158,7 @@ mkDerivation { types-common unliftio unordered-containers + uri-bytestring uuid wai-utilities wire-api diff --git a/services/brig/default.nix b/services/brig/default.nix index 20eb64d007b..c358a046d77 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -129,7 +129,6 @@ , template-haskell , temporary , text -, text-icu-translit , time , time-out , time-units @@ -245,7 +244,6 @@ mkDerivation { resourcet retry safe-exceptions - saml2-web-sso schema-profunctor scientific servant @@ -260,7 +258,6 @@ mkDerivation { template template-haskell text - text-icu-translit time time-out time-units From f170493395d87f04aedbb7c549fee1a88fd7da77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 20 Aug 2024 14:44:19 +0200 Subject: [PATCH 12/48] Rename an effect action --- libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs | 2 +- .../src/Wire/UserSearchSubsystem/Interpreter.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs index 5b8b23cb2e2..5e013501801 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs @@ -23,7 +23,7 @@ data BrowseTeamFilters = BrowseTeamFilters data UserSearchSubsystem m a where SyncUser :: UserId -> UserSearchSubsystem m () UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSearchSubsystem m () - SearchUser :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m [Contact] + SearchUsers :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m [Contact] BrowseTeam :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> UserSearchSubsystem m [TeamContact] makeSem ''UserSearchSubsystem diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index 13b208cbea2..24228cb3cbe 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -42,7 +42,7 @@ interpretUserSearchSubsystem :: interpretUserSearchSubsystem = interpret \case SyncUser uid -> syncUserImpl uid UpdateTeamSearchVisibilityInbound status -> updateTeamSearchVisibilityInboundImpl status - SearchUser luid query mDomain mMaxResults -> searchUserImpl luid query mDomain mMaxResults + SearchUsers luid query mDomain mMaxResults -> searchUsersImpl luid query mDomain mMaxResults BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> do browseTeamImpl uid browseTeamFilters mMaxResults mPagingState @@ -150,8 +150,8 @@ updateTeamSearchVisibilityInboundImpl teamStatus = IndexedUserStore.updateTeamSearchVisibilityInbound teamStatus.team $ searchVisibilityInboundFromFeatureStatus teamStatus.status -searchUserImpl :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> Sem r [Contact] -searchUserImpl = undefined +searchUsersImpl :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> Sem r [Contact] +searchUsersImpl = undefined browseTeamImpl :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> Sem r [TeamContact] browseTeamImpl = undefined From 46e8629b5424ec9531e3b2d1de9bba5ba3968bf9 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 21 Aug 2024 17:00:19 +0200 Subject: [PATCH 13/48] WIP: Move search code to subsystem --- .../src/Wire/API/Routes/Public/Brig.hs | 2 +- .../Wire/FederationAPIAccess/Interpreter.hs | 9 + .../src/Wire}/FederationConfigStore.hs | 2 +- .../src/Wire/IndexedUserStore.hs | 4 +- .../Wire/IndexedUserStore/ElasticSearch.hs | 210 ++++++++++++++++++ .../src/Wire/UserSearchSubsystem.hs | 2 +- .../Wire/UserSearchSubsystem/Interpreter.hs | 206 ++++++++++++++++- .../wire-subsystems/src/Wire/UserSubsystem.hs | 3 + .../src/Wire/UserSubsystem/Error.hs | 2 + .../src/Wire/UserSubsystem/Interpreter.hs | 9 +- .../Wire/UserSubsystem/InterpreterSpec.hs | 33 ++- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/brig.cabal | 1 - services/brig/src/Brig/API/Connection.hs | 2 +- .../brig/src/Brig/API/Connection/Remote.hs | 2 +- services/brig/src/Brig/API/Federation.hs | 4 +- services/brig/src/Brig/API/Internal.hs | 14 +- services/brig/src/Brig/API/Public.hs | 17 +- .../brig/src/Brig/CanonicalInterpreter.hs | 7 +- .../FederationConfigStore/Cassandra.hs | 4 +- services/brig/src/Brig/Index/Eval.hs | 33 ++- services/brig/src/Brig/Team/Util.hs | 4 + services/brig/src/Brig/User/API/Search.hs | 4 +- .../brig/src/Brig/User/Search/SearchIndex.hs | 8 +- 24 files changed, 525 insertions(+), 58 deletions(-) rename {services/brig/src/Brig/Effects => libs/wire-subsystems/src/Wire}/FederationConfigStore.hs (96%) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 29f05a6b708..44aefdaa88a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -1178,7 +1178,7 @@ type ConnectionAPI = ( Summary "Search for users" :> MakesFederatedCall 'Brig "get-users-by-ids" :> MakesFederatedCall 'Brig "search-users" - :> ZUser + :> ZLocalUser :> "search" :> "contacts" :> QueryParam' '[Required, Strict, Description "Search query"] "q" Text diff --git a/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs b/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs index 8520f11ff69..39f99b10e64 100644 --- a/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs @@ -22,6 +22,15 @@ data FederationAPIAccessConfig = FederationAPIAccessConfig type FederatedActionRunner fedM r = forall c x. Domain -> fedM c x -> Sem r (Either FederationError x) +noFederationAPIAccess :: + forall r fedM. + (Member (Concurrency 'Unsafe) r) => + InterpreterFor (FederationAPIAccess fedM) r +noFederationAPIAccess = + interpretFederationAPIAccessGeneral + (\_ _ -> pure $ Left FederationNotConfigured) + (pure False) + interpretFederationAPIAccess :: forall r. (Member (Embed IO) r, Member (Concurrency 'Unsafe) r) => diff --git a/services/brig/src/Brig/Effects/FederationConfigStore.hs b/libs/wire-subsystems/src/Wire/FederationConfigStore.hs similarity index 96% rename from services/brig/src/Brig/Effects/FederationConfigStore.hs rename to libs/wire-subsystems/src/Wire/FederationConfigStore.hs index 07ace482740..c043af54184 100644 --- a/services/brig/src/Brig/Effects/FederationConfigStore.hs +++ b/libs/wire-subsystems/src/Wire/FederationConfigStore.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Brig.Effects.FederationConfigStore where +module Wire.FederationConfigStore where import Data.Domain import Data.Id diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs index 89569393a2f..c8ab65e43db 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs @@ -3,9 +3,10 @@ module Wire.IndexedUserStore where import Data.Id -import Database.Bloodhound.Types +import Database.Bloodhound.Types hiding (SearchResult) import Imports import Polysemy +import Wire.API.User.Search import Wire.UserSearch.Migration import Wire.UserSearch.Types @@ -15,6 +16,7 @@ data IndexedUserStore m a where -- | Will only be applied to main ES index and not the additional one BulkUpsert :: [(DocId, UserDoc, VersionControl)] -> IndexedUserStore m () DoesIndexExist :: IndexedUserStore m Bool + SearchUsers :: UserId -> Maybe TeamId -> TeamSearchInfo -> Text -> Int -> IndexedUserStore m (SearchResult UserDoc) makeSem ''IndexedUserStore diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index d2f59c0fc62..f8dc770a679 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -13,11 +13,13 @@ import Imports import Network.HTTP.Client import Network.HTTP.Types import Polysemy +import Wire.API.User.Search import Wire.IndexedUserStore import Wire.Sem.Metrics (Metrics) import Wire.Sem.Metrics qualified as Metrics import Wire.UserSearch.Metrics import Wire.UserSearch.Types +import Wire.UserStore.IndexUser data ESConn = ESConn { env :: ES.BHEnv, @@ -49,6 +51,7 @@ interpretIndexedUserStoreES cfg = UpdateTeamSearchVisibilityInbound tid vis -> updateTeamSearchVisibilityInboundImpl cfg tid vis BulkUpsert docs -> bulkUpsertImpl cfg docs DoesIndexExist -> doesIndexExistImpl cfg + SearchUsers searcherId mSearcherTeam teamSearchInfo term maxResults -> searchUsersImpl cfg searcherId mSearcherTeam teamSearchInfo term maxResults upsertImpl :: forall r. @@ -150,6 +153,210 @@ doesIndexExistImpl cfg = do (mainExists, fromMaybe True -> additionalExists) <- runInBothES cfg ES.indexExists pure $ mainExists && additionalExists +searchUsersImpl :: + (Member (Embed IO) r) => + IndexedUserStoreConfig -> + UserId -> + Maybe TeamId -> + TeamSearchInfo -> + Text -> + Int -> + Sem r (SearchResult UserDoc) +searchUsersImpl cfg searcherId mSearcherTeam teamSearchInfo term maxResults = + queryIndex cfg maxResults $ + defaultUserQuery searcherId mSearcherTeam teamSearchInfo term + +queryIndex :: + (Member (Embed IO) r) => + IndexedUserStoreConfig -> + Int -> + IndexQuery x -> + Sem r (SearchResult UserDoc) +queryIndex cfg s (IndexQuery q f _) = do + -- localDomain <- viewFederationDomain + let search = (ES.mkSearch (Just q) (Just f)) {ES.size = ES.Size (fromIntegral s)} + r <- ES.runBH cfg.conn.env $ do + res <- ES.searchByType cfg.conn.indexName mappingName search + liftIO $ ES.parseEsResponse @_ @(ES.SearchResult UserDoc) res + either (embed . throwIO . IndexLookupError) (pure . mkResult) r + where + mkResult es = + let results = mapMaybe ES.hitSource . ES.hits . ES.searchHits $ es + in SearchResult + { searchFound = ES.hitsTotal . ES.searchHits $ es, + searchReturned = length results, + searchTook = ES.took es, + searchResults = results, + searchPolicy = FullSearch, + searchPagingState = Nothing, + searchHasMore = Nothing + } + +-- | The default or canonical 'IndexQuery'. +-- +-- The intention behind parameterising 'queryIndex' over the 'IndexQuery' is that +-- it allows to experiment with different queries (perhaps in an A/B context). +-- +-- FUTUREWORK: Drop legacyPrefixMatch +defaultUserQuery :: UserId -> Maybe TeamId -> TeamSearchInfo -> Text -> IndexQuery Contact +defaultUserQuery searcher mSearcherTeamId teamSearchInfo (normalized -> term') = + let matchPhraseOrPrefix = + ES.QueryMultiMatchQuery $ + ( ES.mkMultiMatchQuery + [ ES.FieldName "handle.prefix^2", + ES.FieldName "normalized.prefix", + ES.FieldName "normalized^3" + ] + (ES.QueryString term') + ) + { ES.multiMatchQueryType = Just ES.MultiMatchMostFields, + ES.multiMatchQueryOperator = ES.And + } + query = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = + [ ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = [matchPhraseOrPrefix], + -- This removes exact handle matches, as they are fetched from cassandra + ES.boolQueryMustNotMatch = [termQ "handle" term'] + } + ], + ES.boolQueryShouldMatch = [ES.QueryExistsQuery (ES.FieldName "handle")] + } + -- This reduces relevance on users not in team of search by 90% (no + -- science behind that number). If the searcher is not part of a team the + -- relevance is not reduced for any users. + queryWithBoost = + ES.QueryBoostingQuery + ES.BoostingQuery + { ES.positiveQuery = query, + ES.negativeQuery = maybe ES.QueryMatchNoneQuery matchUsersNotInTeam mSearcherTeamId, + ES.negativeBoost = ES.Boost 0.1 + } + in mkUserQuery searcher mSearcherTeamId teamSearchInfo queryWithBoost + +mkUserQuery :: UserId -> Maybe TeamId -> TeamSearchInfo -> ES.Query -> IndexQuery Contact +mkUserQuery searcher mSearcherTeamId teamSearchInfo q = + IndexQuery + q + ( ES.Filter + . ES.QueryBoolQuery + $ boolQuery + { ES.boolQueryMustNotMatch = maybeToList $ matchSelf searcher, + ES.boolQueryMustMatch = + [ restrictSearchSpace mSearcherTeamId teamSearchInfo, + ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = + [ termQ "account_status" "active", + -- Also match entries where the account_status field is not present. + -- These must have been inserted before we added the account_status + -- and at that time we only inserted active users in the first place. + -- This should be unnecessary after re-indexing, but let's be lenient + -- here for a while. + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = + [ES.QueryExistsQuery (ES.FieldName "account_status")] + } + ] + } + ] + } + ) + [] + +termQ :: Text -> Text -> ES.Query +termQ f v = + ES.TermQuery + ES.Term + { ES.termField = f, + ES.termValue = v + } + Nothing + +matchSelf :: UserId -> Maybe ES.Query +matchSelf searcher = Just (termQ "_id" (idToText searcher)) + +-- | See 'TeamSearchInfo' +restrictSearchSpace :: Maybe TeamId -> TeamSearchInfo -> ES.Query +-- restrictSearchSpace (FederatedSearch Nothing) = +-- ES.QueryBoolQuery +-- boolQuery +-- { ES.boolQueryShouldMatch = +-- [ matchNonTeamMemberUsers, +-- matchTeamMembersSearchableByAllTeams +-- ] +-- } +-- restrictSearchSpace (FederatedSearch (Just [])) = +-- ES.QueryBoolQuery +-- boolQuery +-- { ES.boolQueryMustMatch = +-- [ -- if the list of allowed teams is empty, this is impossible to fulfill, and no results will be returned +-- -- this case should be handled earlier, so this is just a safety net +-- ES.TermQuery (ES.Term "team" "must not match any team") Nothing +-- ] +-- } +-- restrictSearchSpace (FederatedSearch (Just teams)) = +-- ES.QueryBoolQuery +-- boolQuery +-- { ES.boolQueryMustMatch = +-- [ matchTeamMembersSearchableByAllTeams, +-- onlyInTeams +-- ] +-- } +-- where +-- onlyInTeams = ES.QueryBoolQuery boolQuery {ES.boolQueryShouldMatch = map matchTeamMembersOf teams} +restrictSearchSpace mteam searchInfo = + case (mteam, searchInfo) of + (Nothing, _) -> matchNonTeamMemberUsers + (Just _, NoTeam) -> matchNonTeamMemberUsers + (Just searcherTeam, TeamOnly team) -> + if searcherTeam == team + then matchTeamMembersOf team + else ES.QueryMatchNoneQuery + (Just searcherTeam, AllUsers) -> + ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = + [ matchNonTeamMemberUsers, + matchTeamMembersSearchableByAllTeams, + matchTeamMembersOf searcherTeam + ] + } + +matchTeamMembersOf :: TeamId -> ES.Query +matchTeamMembersOf team = ES.TermQuery (ES.Term "team" $ idToText team) Nothing + +matchTeamMembersSearchableByAllTeams :: ES.Query +matchTeamMembersSearchableByAllTeams = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = + [ ES.QueryExistsQuery $ ES.FieldName "team", + ES.TermQuery (ES.Term (Key.toText searchVisibilityInboundFieldName) "searchable-by-all-teams") Nothing + ] + } + +matchNonTeamMemberUsers :: ES.Query +matchNonTeamMemberUsers = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = [ES.QueryExistsQuery $ ES.FieldName "team"] + } + +matchUsersNotInTeam :: TeamId -> ES.Query +matchUsersNotInTeam tid = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = [ES.TermQuery (ES.Term "team" $ idToText tid) Nothing] + } + +-------------------------------------------- +-- Utils + runInBothES :: (Monad m) => IndexedUserStoreConfig -> (ES.IndexName -> ES.BH m a) -> m (a, Maybe a) runInBothES cfg f = do x <- ES.runBH cfg.conn.env $ f cfg.conn.indexName @@ -159,3 +366,6 @@ runInBothES cfg f = do mappingName :: ES.MappingName mappingName = ES.MappingName "user" + +boolQuery :: ES.BoolQuery +boolQuery = ES.mkBoolQuery [] [] [] [] diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs index 5e013501801..84bf74bed2b 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs @@ -23,7 +23,7 @@ data BrowseTeamFilters = BrowseTeamFilters data UserSearchSubsystem m a where SyncUser :: UserId -> UserSearchSubsystem m () UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSearchSubsystem m () - SearchUsers :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m [Contact] + SearchUsers :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m (SearchResult Contact) BrowseTeam :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> UserSearchSubsystem m [TeamContact] makeSem ''UserSearchSubsystem diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index 24228cb3cbe..9541a725312 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -2,8 +2,10 @@ module Wire.UserSearchSubsystem.Interpreter where import Cassandra.Exec (paginateWithStateC) import Conduit (ConduitT, runConduit, (.|)) +import Control.Error (MaybeT (..)) import Data.Conduit.Combinators qualified as Conduit import Data.Domain +import Data.Handle qualified as Handle import Data.Id import Data.Map qualified as Map import Data.Qualified @@ -15,34 +17,58 @@ import Polysemy import Polysemy.Error import Polysemy.TinyLog import Polysemy.TinyLog qualified as Log +import Servant.Client.Core (RunClient) import System.Logger.Message qualified as Log +import Wire.API.Federation.API +import Wire.API.Federation.API.Brig qualified as FedBrig +import Wire.API.Federation.Error +import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) import Wire.API.Team.Feature +import Wire.API.Team.Member +import Wire.API.Team.SearchVisibility +import Wire.API.User import Wire.API.User.Search +import Wire.FederationAPIAccess +import Wire.FederationConfigStore import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.IndexedUserStore (IndexedUserMigrationStore, IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) import Wire.Sem.Metrics (Metrics) import Wire.Sem.Metrics qualified as Metrics +import Wire.StoredUser import Wire.UserSearch.Metrics import Wire.UserSearch.Migration import Wire.UserSearch.Types import Wire.UserSearchSubsystem import Wire.UserStore +import Wire.UserStore qualified as UserStore import Wire.UserStore.IndexUser +import Wire.UserSubsystem.Error +import Wire.UserSubsystem.Interpreter interpretUserSearchSubsystem :: ( Member UserStore r, Member GalleyAPIAccess r, Member IndexedUserStore r, - Member Metrics r + Member Metrics r, + Member (Error UserSubsystemError) r, + Member FederationConfigStore r, + RunClient (fedM 'Brig), + Member (FederationAPIAccess fedM) r, + FederationMonad fedM, + Typeable fedM, + Member TinyLog r, + Member (Error FederationError) r ) => + UserSubsystemConfig -> InterpreterFor UserSearchSubsystem r -interpretUserSearchSubsystem = interpret \case +interpretUserSearchSubsystem config = interpret \case SyncUser uid -> syncUserImpl uid UpdateTeamSearchVisibilityInbound status -> updateTeamSearchVisibilityInboundImpl status - SearchUsers luid query mDomain mMaxResults -> searchUsersImpl luid query mDomain mMaxResults + SearchUsers luid query mDomain mMaxResults -> searchUsersImpl config luid query mDomain mMaxResults BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> do browseTeamImpl uid browseTeamFilters mMaxResults mPagingState @@ -150,8 +176,178 @@ updateTeamSearchVisibilityInboundImpl teamStatus = IndexedUserStore.updateTeamSearchVisibilityInbound teamStatus.team $ searchVisibilityInboundFromFeatureStatus teamStatus.status -searchUsersImpl :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> Sem r [Contact] -searchUsersImpl = undefined +searchUsersImpl :: + forall r fedM. + ( Member UserStore r, + Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r, + Member IndexedUserStore r, + Member FederationConfigStore r, + RunClient (fedM 'Brig), + Member (FederationAPIAccess fedM) r, + FederationMonad fedM, + Typeable fedM, + Member TinyLog r, + Member (Error FederationError) r + ) => + UserSubsystemConfig -> + Local UserId -> + Text -> + Maybe Domain -> + Maybe (Range 1 500 Int32) -> + Sem r (SearchResult Contact) +searchUsersImpl config searcherId searchTerm maybeDomain maybeMaxResults = do + -- FUTUREWORK(fisx): to reduce cassandra traffic, 'ensurePermissionsOrPersonalUser' could be + -- run from `searchLocally` and `searchRemotely`, resp., where the team id is already + -- available (at least in the local case) and can be passed as an argument rather than + -- looked up again. + -- user <- fromMaybe (error "TODO: searcher is not real") <$> UserSubsystem.getLocalUser searcherId + storedSearcher <- fromMaybe (error "TODO: searcher is not real") <$> UserStore.getUser (tUnqualified searcherId) + for_ storedSearcher.teamId $ \tid -> ensurePermissions (tUnqualified searcherId) tid [SearchContacts] + let localDomain = tDomain searcherId + let queryDomain = fromMaybe localDomain maybeDomain + if queryDomain == localDomain + then searchLocally config (qualifyAs searcherId storedSearcher) searchTerm maybeMaxResults + else searchRemotely queryDomain storedSearcher.teamId searchTerm + where + ensurePermissions :: (IsPerm perm) => UserId -> TeamId -> [perm] -> Sem r () + ensurePermissions u t perms = do + m <- GalleyAPIAccess.getTeamMember u t + unless (check m) $ + throw UserSubsystemInsufficientTeamPermissions + where + check :: Maybe TeamMember -> Bool + check (Just m) = all (hasPermission m) perms + check Nothing = False + +searchLocally :: + forall r. + ( Member GalleyAPIAccess r, + Member UserStore r, + Member IndexedUserStore r + ) => + UserSubsystemConfig -> + Local StoredUser -> + Text -> + Maybe (Range 1 500 Int32) -> + Sem r (SearchResult Contact) +searchLocally config searcher searchTerm maybeMaxResults = do + let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults + let searcherTeamId = (tUnqualified searcher).teamId + searcherId = (tUnqualified searcher).id + teamSearchInfo <- mkTeamSearchInfo searcherTeamId + + maybeExactHandleMatch <- exactHandleSearch teamSearchInfo + + let exactHandleMatchCount = length maybeExactHandleMatch + esMaxResults = maxResults - exactHandleMatchCount + + esResult <- + if esMaxResults > 0 + then IndexedUserStore.searchUsers searcherId searcherTeamId teamSearchInfo searchTerm esMaxResults + else pure $ SearchResult 0 0 0 [] FullSearch Nothing Nothing + + -- Prepend results matching exact handle and results from ES. + pure $ + esResult + { searchResults = maybeToList maybeExactHandleMatch <> map userDocToContact (searchResults esResult), + searchFound = exactHandleMatchCount + searchFound esResult, + searchReturned = exactHandleMatchCount + searchReturned esResult + } + where + handleTeamVisibility :: TeamId -> TeamSearchVisibility -> TeamSearchInfo + handleTeamVisibility _ SearchVisibilityStandard = AllUsers + handleTeamVisibility t SearchVisibilityNoNameOutsideTeam = TeamOnly t + + userDocToContact :: UserDoc -> Contact + userDocToContact userDoc = + Contact + { contactQualifiedId = tUntagged $ qualifyAs searcher userDoc.udId, + contactName = maybe "" fromName userDoc.udName, + contactColorId = fromIntegral . fromColourId <$> userDoc.udColourId, + contactHandle = Handle.fromHandle <$> userDoc.udHandle, + contactTeam = userDoc.udTeam + } + + mkTeamSearchInfo :: Maybe TeamId -> Sem r TeamSearchInfo + mkTeamSearchInfo searcherTeamId = do + case searcherTeamId of + Nothing -> pure NoTeam + Just t -> + -- This flag in brig overrules any flag on galley - it is system wide + if config.searchSameTeamOnly + then pure (TeamOnly t) + else do + -- For team users, we need to check the visibility flag + handleTeamVisibility t <$> GalleyAPIAccess.getTeamSearchVisibility t + + exactHandleSearch :: TeamSearchInfo -> Sem r (Maybe Contact) + exactHandleSearch _teamSerachInfo = runMaybeT $ do + handle <- MaybeT . pure $ Handle.parseHandle searchTerm + owner <- MaybeT $ UserStore.lookupHandle handle + storedUser <- MaybeT $ UserStore.getUser owner + let contact = contactFromStoredUser (tDomain searcher) storedUser + isContactVisible = + (config.searchSameTeamOnly && (tUnqualified searcher).teamId == storedUser.teamId) + || (not config.searchSameTeamOnly) + -- case teamSerachInfo of + -- AllUsers -> True + -- NoTeam -> isNothing (storedUser.teamId) + -- TeamOnly tid -> storedUser.teamId == Just tid + if isContactVisible + then pure contact + else MaybeT $ pure Nothing + + contactFromStoredUser :: Domain -> StoredUser -> Contact + contactFromStoredUser domain storedUser = + Contact + { contactQualifiedId = Qualified storedUser.id domain, + contactName = fromName storedUser.name, + contactHandle = Handle.fromHandle <$> storedUser.handle, + contactColorId = Just . fromIntegral . fromColourId $ storedUser.accentId, + contactTeam = storedUser.teamId + } + +searchRemotely :: + ( Member FederationConfigStore r, + RunClient (fedM 'Brig), + Member (FederationAPIAccess fedM) r, + FederationMonad fedM, + Typeable fedM, + Member TinyLog r, + Member (Error FederationError) r + ) => + Domain -> + Maybe TeamId -> + Text -> + Sem r (SearchResult Contact) +searchRemotely domain mTid searchTerm = do + Log.info $ + Log.msg (Log.val "searchRemotely") + . Log.field "domain" (show domain) + . Log.field "searchTerm" searchTerm + mFedCnf <- getFederationConfig domain + let onlyInTeams = case restriction <$> mFedCnf of + Just FederationRestrictionAllowAll -> Nothing + Just (FederationRestrictionByTeam teams) -> Just teams + -- if we are not federating at all, we also do not allow to search any remote teams + Nothing -> Just [] + + searchResponse <- + runFederated (toRemoteUnsafe domain ()) $ + fedClient @'Brig @"search-users" (FedBrig.SearchRequest searchTerm mTid onlyInTeams) + let contacts = searchResponse.contacts + let count = length contacts + pure + SearchResult + { searchResults = contacts, + searchFound = count, + searchReturned = count, + searchTook = 0, + searchPolicy = searchResponse.searchPolicy, + searchPagingState = Nothing, + searchHasMore = Nothing + } browseTeamImpl :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> Sem r [TeamContact] browseTeamImpl = undefined diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 3a0cab37a6a..a6da88cc69e 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -96,3 +96,6 @@ getUserProfile luid targetUser = getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserProfile) getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) + +getLocalUser :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe User) +getLocalUser = (selfUser <$$>) . getSelfProfile diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index 40006412b47..22b1a8e44ec 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -16,6 +16,7 @@ data UserSubsystemError | UserSubsystemHandleExists | UserSubsystemInvalidHandle | UserSubsystemProfileNotFound + | UserSubsystemInsufficientTeamPermissions deriving (Eq, Show) userSubsystemErrorToHttpError :: UserSubsystemError -> HttpError @@ -28,5 +29,6 @@ userSubsystemErrorToHttpError = UserSubsystemHandleExists -> errorToWai @E.HandleExists UserSubsystemInvalidHandle -> errorToWai @E.InvalidHandle UserSubsystemHandleManagedByScim -> errorToWai @E.HandleManagedByScim + UserSubsystemInsufficientTeamPermissions -> errorToWai @'E.InsufficientTeamPermissions instance Exception UserSubsystemError diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 39dd0e179af..5da14f2f4ae 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -44,12 +44,11 @@ import Wire.UserSubsystem.HandleBlacklist data UserSubsystemConfig = UserSubsystemConfig { emailVisibilityConfig :: EmailVisibilityConfig, - defaultLocale :: Locale + defaultLocale :: Locale, + searchSameTeamOnly :: Bool } - deriving (Show) - -instance Arbitrary UserSubsystemConfig where - arbitrary = UserSubsystemConfig <$> arbitrary <*> arbitrary + deriving (Show, Generic) + deriving (Arbitrary) via (GenericUniform UserSubsystemConfig) runUserSubsystem :: ( Member GalleyAPIAccess r, diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 9a98d7b1ae5..22285a5dac6 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -54,8 +54,9 @@ spec = describe "UserSubsystem.Interpreter" do target1 = mkUserIds remoteDomain1 targetUsers1 target2 = mkUserIds remoteDomain2 targetUsers2 localBackend = def {users = [viewer] <> localTargetUsers} + config = UserSubsystemConfig visibility miniLocale False retrievedProfiles = - runFederationStack localBackend federation Nothing (UserSubsystemConfig visibility miniLocale) $ + runFederationStack localBackend federation Nothing config $ getUserProfiles (toLocalUnsafe localDomain viewer.id) (localTargets <> target1 <> target2) @@ -81,7 +82,7 @@ spec = describe "UserSubsystem.Interpreter" do mkUserIds domain users = map (flip Qualified domain . (.id)) users onlineUsers = mkUserIds onlineDomain onlineTargetUsers offlineUsers = mkUserIds offlineDomain offlineTargetUsers - config = UserSubsystemConfig visibility miniLocale + config = UserSubsystemConfig visibility miniLocale False localBackend = def {users = [viewer]} result = run @@ -100,49 +101,45 @@ spec = describe "UserSubsystem.Interpreter" do describe "[without federation]" do prop "returns nothing when none of the users exist" $ - \viewer targetUserIds visibility domain locale -> - let config = UserSubsystemConfig visibility locale - retrievedProfiles = + \viewer targetUserIds config domain -> + let retrievedProfiles = runNoFederationStack def Nothing config $ getUserProfiles (toLocalUnsafe domain viewer) (map (`Qualified` domain) targetUserIds) in retrievedProfiles === [] prop "gets a local user profile when the user exists and both user and viewer have accepted their invitations" $ - \(NotPendingStoredUser viewer) (NotPendingStoredUser targetUserNoTeam) visibility domain locale sameTeam -> + \(NotPendingStoredUser viewer) (NotPendingStoredUser targetUserNoTeam) config domain sameTeam -> let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus targetUser = if sameTeam then targetUserNoTeam {teamId = viewer.teamId} else targetUserNoTeam - config = UserSubsystemConfig visibility locale localBackend = def {users = [targetUser, viewer]} retrievedProfiles = runNoFederationStack localBackend (Just teamMember) config $ getUserProfiles (toLocalUnsafe domain viewer.id) [Qualified targetUser.id domain] in retrievedProfiles === [ mkUserProfile - (fmap (const $ (,) <$> viewer.teamId <*> Just teamMember) visibility) - (mkUserFromStored domain locale targetUser) + (fmap (const $ (,) <$> viewer.teamId <*> Just teamMember) config.emailVisibilityConfig) + (mkUserFromStored domain config.defaultLocale targetUser) defUserLegalHoldStatus ] prop "gets a local user profile when the target user exists and has accepted their invitation but the viewer has not accepted their invitation" $ - \(PendingStoredUser viewer) (NotPendingStoredUser targetUserNoTeam) visibility domain locale sameTeam -> + \(PendingStoredUser viewer) (NotPendingStoredUser targetUserNoTeam) config domain sameTeam -> let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus targetUser = if sameTeam then targetUserNoTeam {teamId = viewer.teamId} else targetUserNoTeam - config = UserSubsystemConfig visibility locale localBackend = def {users = [targetUser, viewer]} retrievedProfile = runNoFederationStack localBackend (Just teamMember) config $ getUserProfiles (toLocalUnsafe domain viewer.id) [Qualified targetUser.id domain] in retrievedProfile === [ mkUserProfile - (fmap (const Nothing) visibility) - (mkUserFromStored domain locale targetUser) + (fmap (const Nothing) config.emailVisibilityConfig) + (mkUserFromStored domain config.defaultLocale targetUser) defUserLegalHoldStatus ] prop "returns Nothing if the target user has not accepted their invitation yet" $ - \viewer (PendingStoredUser targetUser) visibility domain locale -> + \viewer (PendingStoredUser targetUser) config domain -> let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus - config = UserSubsystemConfig visibility locale localBackend = def {users = [targetUser, viewer]} retrievedProfile = runNoFederationStack localBackend (Just teamMember) config $ @@ -154,7 +151,7 @@ spec = describe "UserSubsystem.Interpreter" do \viewer targetUsers visibility domain remoteDomain -> do let remoteBackend = def {users = targetUsers} federation = [(remoteDomain, remoteBackend)] - config = UserSubsystemConfig visibility miniLocale + config = UserSubsystemConfig visibility miniLocale False localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend federation Nothing config $ @@ -175,7 +172,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "Remote users on offline backend always fail to return" $ \viewer (targetUsers :: Set StoredUser) visibility domain remoteDomain -> do let online = mempty - config = UserSubsystemConfig visibility miniLocale + config = UserSubsystemConfig visibility miniLocale False localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend online Nothing config $ @@ -195,7 +192,7 @@ spec = describe "UserSubsystem.Interpreter" do allDomains = [domain, remoteDomainA, remoteDomainB] remoteAUsers = map (flip Qualified remoteDomainA . (.id)) targetUsers remoteBUsers = map (flip Qualified remoteDomainB . (.id)) targetUsers - config = UserSubsystemConfig visibility miniLocale + config = UserSubsystemConfig visibility miniLocale False localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend online Nothing config $ diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 0c8a7a1979a..b8772ff38a4 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -87,6 +87,7 @@ library Wire.Events Wire.FederationAPIAccess Wire.FederationAPIAccess.Interpreter + Wire.FederationConfigStore Wire.GalleyAPIAccess Wire.GalleyAPIAccess.Rpc Wire.GundeckAPIAccess diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 54c50ea2db4..98456004b06 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -114,7 +114,6 @@ library Brig.DeleteQueue.Interpreter Brig.Effects.ConnectionStore Brig.Effects.ConnectionStore.Cassandra - Brig.Effects.FederationConfigStore Brig.Effects.FederationConfigStore.Cassandra Brig.Effects.JwtTools Brig.Effects.PublicKeyBundle diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index f718cd465d1..cd2592f764d 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -41,7 +41,6 @@ import Brig.App import Brig.Data.Connection qualified as Data import Brig.Data.Types (resultHasMore, resultList) import Brig.Data.User qualified as Data -import Brig.Effects.FederationConfigStore import Brig.IO.Intra qualified as Intra import Brig.IO.Logging import Brig.Options @@ -68,6 +67,7 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.API.UserEvent +import Wire.FederationConfigStore import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 03b650731c8..3a812f665d6 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -28,7 +28,6 @@ import Brig.API.Types (ConnectionError (..)) import Brig.App import Brig.Data.Connection qualified as Data import Brig.Data.User qualified as Data -import Brig.Effects.FederationConfigStore import Brig.Federation.Client as Federation import Brig.IO.Intra qualified as Intra import Brig.Options @@ -51,6 +50,7 @@ import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.API.UserEvent +import Wire.FederationConfigStore import Wire.GalleyAPIAccess import Wire.NotificationSubsystem import Wire.UserStore diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 58af99451bf..f959faa2c2d 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -31,8 +31,6 @@ import Brig.API.User qualified as API import Brig.App import Brig.Data.Connection qualified as Data import Brig.Data.User qualified as Data -import Brig.Effects.FederationConfigStore (FederationConfigStore) -import Brig.Effects.FederationConfigStore qualified as E import Brig.IO.Intra (notify) import Brig.Options import Brig.User.API.Handle @@ -72,6 +70,8 @@ import Wire.API.UserEvent import Wire.API.UserMap (UserMap) import Wire.DeleteQueue import Wire.Error +import Wire.FederationConfigStore (FederationConfigStore) +import Wire.FederationConfigStore qualified as E import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.NotificationSubsystem import Wire.Sem.Concurrency diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 2c9f96a564d..f4b08922933 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -38,13 +38,6 @@ import Brig.Data.Connection qualified as Data import Brig.Data.MLS.KeyPackage qualified as Data import Brig.Data.User qualified as Data import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.FederationConfigStore - ( AddFederationRemoteResult (..), - AddFederationRemoteTeamResult (..), - FederationConfigStore, - UpdateFederationResult (..), - ) -import Brig.Effects.FederationConfigStore qualified as E import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) @@ -102,6 +95,13 @@ import Wire.BlockListStore (BlockListStore) import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem (EmailSubsystem) +import Wire.FederationConfigStore + ( AddFederationRemoteResult (..), + AddFederationRemoteTeamResult (..), + FederationConfigStore, + UpdateFederationResult (..), + ) +import Wire.FederationConfigStore qualified as E import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.NotificationSubsystem import Wire.PropertySubsystem diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 60980cb39db..94dfcbe3fc5 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -42,7 +42,6 @@ import Brig.Data.Connection qualified as Data import Brig.Data.Nonce as Nonce import Brig.Data.User qualified as Data import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.JwtTools (JwtTools) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) import Brig.Effects.SFT @@ -56,7 +55,6 @@ import Brig.Types.Intra (UserAccount (UserAccount, accountUser)) import Brig.Types.User (HavePendingInvitations (..)) import Brig.User.API.Handle qualified as Handle import Brig.User.API.Search (teamUserSearch) -import Brig.User.API.Search qualified as Search import Brig.User.Auth.Cookie qualified as Auth import Cassandra qualified as C import Cassandra qualified as Data @@ -142,6 +140,7 @@ import Wire.API.User.Client.Prekey qualified as Public import Wire.API.User.Handle qualified as Public import Wire.API.User.Password qualified as Public import Wire.API.User.RichInfo qualified as Public +import Wire.API.User.Search qualified as Public import Wire.API.UserMap qualified as Public import Wire.API.Wrapped qualified as Public import Wire.AuthenticationSubsystem (AuthenticationSubsystem, createPasswordResetCode, resetPassword) @@ -150,6 +149,7 @@ import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem import Wire.Error +import Wire.FederationConfigStore (FederationConfigStore) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem @@ -161,6 +161,7 @@ import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserSearchSubsystem (UserSearchSubsystem) +import Wire.UserSearchSubsystem qualified as UserSearchSubsystem import Wire.UserStore (UserStore) import Wire.UserSubsystem hiding (checkHandle, checkHandles) import Wire.UserSubsystem qualified as UserSubsystem @@ -397,7 +398,7 @@ servantSitemap = :<|> Named @"get-connection" getConnection :<|> Named @"update-connection-unqualified" (callsFed (exposeAnnotations updateLocalConnection)) :<|> Named @"update-connection" (callsFed (exposeAnnotations updateConnection)) - :<|> Named @"search-contacts" (callsFed (exposeAnnotations Search.search)) + :<|> Named @"search-contacts" (callsFed (exposeAnnotations searchUsersHandler)) propertiesAPI :: ServerT PropertiesAPI (Handler r) propertiesAPI = @@ -1025,6 +1026,16 @@ sendActivationCode ac = do checkAllowlist email API.sendActivationCode email (ac.locale) !>> sendActCodeError +searchUsersHandler :: + (Member UserSearchSubsystem r) => + Local UserId -> + Text -> + Maybe Domain -> + Maybe (Range 1 500 Int32) -> + Handler r (Public.SearchResult Public.Contact) +searchUsersHandler luid term mDomain mMaxResults = + lift . liftSem $ UserSearchSubsystem.searchUsers luid term mDomain mMaxResults + -- | If the user presents an email address from a blocked domain, throw an error. -- -- The tautological constraint in the type signature is added so that once we remove the diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index e7db04ec321..4924fd0c961 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -5,7 +5,6 @@ import Brig.App as App import Brig.DeleteQueue.Interpreter as DQ import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) -import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.FederationConfigStore.Cassandra (interpretFederationDomainConfig, remotesMapFromCfgFile) import Brig.Effects.JwtTools import Brig.Effects.PublicKeyBundle @@ -47,6 +46,7 @@ import Wire.Error import Wire.Events import Wire.FederationAPIAccess qualified import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) +import Wire.FederationConfigStore (FederationConfigStore) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.GundeckAPIAccess @@ -157,7 +157,8 @@ runBrigToIO e (AppT ma) = do let userSubsystemConfig = UserSubsystemConfig { emailVisibilityConfig = e ^. settings . Opt.emailVisibility, - defaultLocale = e ^. settings . to Opt.setDefaultUserLocale + defaultLocale = e ^. settings . to Opt.setDefaultUserLocale, + searchSameTeamOnly = e ^. settings . Opt.searchSameTeamOnly . to (fromMaybe False) } federationApiAccessConfig = FederationAPIAccessConfig @@ -236,7 +237,7 @@ runBrigToIO e (AppT ma) = do . mapError (StdError . federationErrorToWai) . mapError authenticationSubsystemErrorToHttpError . mapError userSubsystemErrorToHttpError - . interpretUserSearchSubsystem + . interpretUserSearchSubsystem userSubsystemConfig . runEvents . runDeleteQueue (e ^. internalEvents) . interpretPropertySubsystem propertySubsystemConfig diff --git a/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs b/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs index 32b13005e25..40d3209f594 100644 --- a/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs +++ b/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs @@ -22,7 +22,6 @@ module Brig.Effects.FederationConfigStore.Cassandra ) where -import Brig.Effects.FederationConfigStore import Cassandra import Control.Exception (ErrorCall (ErrorCall)) import Control.Lens @@ -36,6 +35,7 @@ import Imports import Polysemy import Wire.API.Routes.FederationDomainConfig import Wire.API.User.Search +import Wire.FederationConfigStore -- | Interpreter for getting the federation config from the database and the config file. -- The config file is injected into the interpreter and has precedence over the database. @@ -44,6 +44,8 @@ import Wire.API.User.Search -- If a domain is configured in the config file, it is not allowed to update it in the database. -- If a domain is configured in the config file, it is not allowed to add a team restriction to it in the database. -- In the future the config file will be removed and the database will be the only source of truth. +-- +-- TODO: Just take a ClientState instead of (Embed m) interpretFederationDomainConfig :: forall m r a. ( MonadClient m, diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index f07e4297491..05854017d3f 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -21,9 +21,12 @@ module Brig.Index.Eval where import Brig.App (initHttpManagerWithTLSConfig, mkIndexEnv) +import Brig.Effects.FederationConfigStore.Cassandra (interpretFederationDomainConfig) import Brig.Index.Options import Brig.Options +import Brig.Options qualified as Opt import Brig.User.Search.Index +import Cassandra (Client, runClient) import Cassandra.Options import Cassandra.Util (defInitCassandra) import Control.Exception (throwIO) @@ -39,11 +42,18 @@ import Database.Bloodhound qualified as ES import Database.Bloodhound.Internal.Client (BHEnv (..)) import Imports import Polysemy +import Polysemy.Embed (runEmbedded) import Polysemy.Error import Polysemy.TinyLog hiding (Logger) import System.Logger qualified as Log import System.Logger.Class (Logger) import Util.Options (initCredentials) +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.User +import Wire.FederationAPIAccess +import Wire.FederationAPIAccess.Interpreter (noFederationAPIAccess) +import Wire.FederationConfigStore (FederationConfigStore) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc import Wire.IndexedUserStore @@ -62,15 +72,21 @@ import Wire.UserSearchSubsystem qualified as UserSearchSubsystem import Wire.UserSearchSubsystem.Interpreter import Wire.UserStore import Wire.UserStore.Cassandra +import Wire.UserSubsystem.Error +import Wire.UserSubsystem.Interpreter (UserSubsystemConfig (..)) type BrigIndexEffectStack = [ UserSearchSubsystemBulk, UserSearchSubsystem, + Error UserSubsystemError, + FederationAPIAccess FederatorClient, + Error FederationError, UserStore, IndexedUserStore, Error IndexedUserStoreError, IndexedUserMigrationStore, Error MigrationException, + FederationConfigStore, GalleyAPIAccess, Error ParseException, Rpc, @@ -102,6 +118,15 @@ runSem esConn cas galleyEndpoint logger action = do additionalConn = Nothing } reqId = (RequestId "brig-index") + userSubsystemConfig = + -- These values usually come from brig's config, but in the brig-index + -- CLI we don't have this. These are not really used so it doesn't + -- matter, but they could get used in future causing weird issues. + UserSubsystemConfig + { emailVisibilityConfig = EmailVisibleToSelf, + defaultLocale = Opt.defaultUserLocale, + searchSameTeamOnly = False + } runFinal . embedToFinal . unsafelyPerformConcurrency @@ -110,12 +135,18 @@ runSem esConn cas galleyEndpoint logger action = do . runRpcWithHttp mgr reqId . throwErrorToIOFinal @ParseException . interpretGalleyAPIAccessToRpc mempty galleyEndpoint + . runEmbedded (runClient casClient) + . interpretFederationDomainConfig Nothing mempty + . raiseUnder @(Embed Client) . throwErrorToIOFinal @MigrationException . interpretIndexedUserMigrationStoreES bhEnv . throwErrorToIOFinal @IndexedUserStoreError . interpretIndexedUserStoreES indexedUserStoreConfig . interpretUserStoreCassandra casClient - . interpretUserSearchSubsystem + . throwErrorToIOFinal @FederationError + . noFederationAPIAccess + . throwErrorToIOFinal @UserSubsystemError + . interpretUserSearchSubsystem userSubsystemConfig . interpretUserSearchSubsystemBulk $ action diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 6ab5eab896d..cec7f81351e 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -34,6 +34,10 @@ import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +-- TODO(md): remove ensurePermissionsOrPersonalUser as it's been moved to an +-- interpreter +-- + -- | If the user is in a team, it has to have these permissions. If not, it is a personal -- user with account validation and thus given the permission implicitly. (Used for -- `SearchContactcs`.) diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 94372807f9d..19c68b6ac67 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -26,8 +26,6 @@ import Brig.API.Error (fedError) import Brig.API.Handler import Brig.App import Brig.Data.User qualified as DB -import Brig.Effects.FederationConfigStore -import Brig.Effects.FederationConfigStore qualified as E import Brig.Federation.Client qualified as Federation import Brig.Options qualified as Opts import Brig.Team.Util (ensurePermissions, ensurePermissionsOrPersonalUser) @@ -54,6 +52,8 @@ import Wire.API.Team.Permission qualified as Public import Wire.API.Team.SearchVisibility (TeamSearchVisibility (..)) import Wire.API.User.Search import Wire.API.User.Search qualified as Public +import Wire.FederationConfigStore +import Wire.FederationConfigStore qualified as E import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.UserSearch.Types qualified as Search diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index e7d44d9d982..5089dbc6a9c 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -43,12 +43,12 @@ import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..), mappingN import Wire.UserSearch.Types import Wire.UserStore.IndexUser (normalized) --- | User that is performing the search --- Team of user that is performing the search --- Outgoing search restrictions data SearchSetting = FederatedSearch (Maybe [TeamId]) - | LocalSearch + | -- | User that is performing the search + -- Team of user that is performing the search + -- Outgoing search restrictions + LocalSearch UserId (Maybe TeamId) TeamSearchInfo From 1a0f892a288363bda402e2a8f96f87f2869cd495 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 21 Aug 2024 17:28:57 +0200 Subject: [PATCH 14/48] Move FederationConfigStore.Cassandra out of Brig --- .../src/Wire}/FederationConfigStore/Cassandra.hs | 2 +- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/brig.cabal | 2 -- services/brig/default.nix | 2 -- services/brig/src/Brig/CanonicalInterpreter.hs | 2 +- services/brig/src/Brig/Index/Eval.hs | 2 +- 6 files changed, 4 insertions(+), 7 deletions(-) rename {services/brig/src/Brig/Effects => libs/wire-subsystems/src/Wire}/FederationConfigStore/Cassandra.hs (99%) diff --git a/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/FederationConfigStore/Cassandra.hs similarity index 99% rename from services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs rename to libs/wire-subsystems/src/Wire/FederationConfigStore/Cassandra.hs index 40d3209f594..1ccd7435d60 100644 --- a/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/FederationConfigStore/Cassandra.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Effects.FederationConfigStore.Cassandra +module Wire.FederationConfigStore.Cassandra ( interpretFederationDomainConfig, remotesMapFromCfgFile, AddFederationRemoteResult (..), diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index b8772ff38a4..4e14ae0c000 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -88,6 +88,7 @@ library Wire.FederationAPIAccess Wire.FederationAPIAccess.Interpreter Wire.FederationConfigStore + Wire.FederationConfigStore.Cassandra Wire.GalleyAPIAccess Wire.GalleyAPIAccess.Rpc Wire.GundeckAPIAccess diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 98456004b06..b54d1509c0d 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -114,7 +114,6 @@ library Brig.DeleteQueue.Interpreter Brig.Effects.ConnectionStore Brig.Effects.ConnectionStore.Cassandra - Brig.Effects.FederationConfigStore.Cassandra Brig.Effects.JwtTools Brig.Effects.PublicKeyBundle Brig.Effects.SFT @@ -235,7 +234,6 @@ library , conduit >=1.2.8 , containers >=0.5 , cookie >=0.4 - , cql , cryptobox-haskell >=0.1.1 , crypton , currency-codes >=2.0 diff --git a/services/brig/default.nix b/services/brig/default.nix index c358a046d77..3fc53e7bdf7 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -29,7 +29,6 @@ , conduit , containers , cookie -, cql , cryptobox-haskell , crypton , currency-codes @@ -187,7 +186,6 @@ mkDerivation { conduit containers cookie - cql cryptobox-haskell crypton currency-codes diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 4924fd0c961..7b4f1417472 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -5,7 +5,6 @@ import Brig.App as App import Brig.DeleteQueue.Interpreter as DQ import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) -import Brig.Effects.FederationConfigStore.Cassandra (interpretFederationDomainConfig, remotesMapFromCfgFile) import Brig.Effects.JwtTools import Brig.Effects.PublicKeyBundle import Brig.Effects.SFT (SFT, interpretSFT) @@ -47,6 +46,7 @@ import Wire.Events import Wire.FederationAPIAccess qualified import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) import Wire.FederationConfigStore (FederationConfigStore) +import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig, remotesMapFromCfgFile) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.GundeckAPIAccess diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 05854017d3f..df789da38cb 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -21,7 +21,6 @@ module Brig.Index.Eval where import Brig.App (initHttpManagerWithTLSConfig, mkIndexEnv) -import Brig.Effects.FederationConfigStore.Cassandra (interpretFederationDomainConfig) import Brig.Index.Options import Brig.Options import Brig.Options qualified as Opt @@ -54,6 +53,7 @@ import Wire.API.User import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter (noFederationAPIAccess) import Wire.FederationConfigStore (FederationConfigStore) +import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc import Wire.IndexedUserStore From b0391e4098864cf98bca369a9642fdbf6595cf3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 21 Aug 2024 17:40:32 +0200 Subject: [PATCH 15/48] Remove dead code from Brig.User.API.Search --- services/brig/src/Brig/User/API/Search.hs | 142 +--------------------- 1 file changed, 2 insertions(+), 140 deletions(-) diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 19c68b6ac67..fffd55d37b3 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -16,161 +16,23 @@ -- with this program. If not, see . module Brig.User.API.Search - ( search, - teamUserSearch, + ( teamUserSearch, refreshIndex, ) where -import Brig.API.Error (fedError) import Brig.API.Handler -import Brig.App -import Brig.Data.User qualified as DB -import Brig.Federation.Client qualified as Federation -import Brig.Options qualified as Opts -import Brig.Team.Util (ensurePermissions, ensurePermissionsOrPersonalUser) -import Brig.User.API.Handle qualified as HandleAPI +import Brig.Team.Util (ensurePermissions) import Brig.User.Search.Index -import Brig.User.Search.SearchIndex qualified as Q import Brig.User.Search.TeamUserSearch qualified as Q -import Control.Lens (view) -import Data.Domain (Domain) -import Data.Handle qualified as Handle import Data.Id import Data.Range import Imports -import Network.Wai.Utilities ((!>>)) import Polysemy -import System.Logger (field, msg) -import System.Logger.Class (val, (~~)) -import System.Logger.Class qualified as Log -import Wire.API.Federation.API.Brig qualified as FedBrig -import Wire.API.Federation.API.Brig qualified as S -import Wire.API.Routes.FederationDomainConfig -import Wire.API.Team.Member (HiddenPerm (SearchContacts)) import Wire.API.Team.Permission qualified as Public -import Wire.API.Team.SearchVisibility (TeamSearchVisibility (..)) import Wire.API.User.Search import Wire.API.User.Search qualified as Public -import Wire.FederationConfigStore -import Wire.FederationConfigStore qualified as E import Wire.GalleyAPIAccess (GalleyAPIAccess) -import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -import Wire.UserSearch.Types qualified as Search -import Wire.UserStore (UserStore) -import Wire.UserSubsystem - --- FUTUREWORK: Consider augmenting 'SearchResult' with full user profiles --- for all results. This is tracked in https://wearezeta.atlassian.net/browse/SQCORE-599 -search :: - ( Member GalleyAPIAccess r, - Member FederationConfigStore r, - Member UserStore r, - Member UserSubsystem r - ) => - UserId -> - Text -> - Maybe Domain -> - Maybe (Range 1 500 Int32) -> - (Handler r) (Public.SearchResult Public.Contact) -search searcherId searchTerm maybeDomain maybeMaxResults = do - -- FUTUREWORK(fisx): to reduce cassandra traffic, 'ensurePermissionsOrPersonalUser' could be - -- run from `searchLocally` and `searchRemotely`, resp., where the team id is already - -- available (at least in the local case) and can be passed as an argument rather than - -- looked up again. - ensurePermissionsOrPersonalUser searcherId [SearchContacts] - federationDomain <- viewFederationDomain - mSearcherTeamId <- lift $ wrapClient $ DB.lookupUserTeam searcherId - let queryDomain = fromMaybe federationDomain maybeDomain - if queryDomain == federationDomain - then searchLocally searcherId searchTerm maybeMaxResults - else searchRemotely queryDomain mSearcherTeamId searchTerm - -searchRemotely :: (Member FederationConfigStore r) => Domain -> Maybe TeamId -> Text -> (Handler r) (Public.SearchResult Public.Contact) -searchRemotely domain mTid searchTerm = do - lift . Log.info $ - msg (val "searchRemotely") - ~~ field "domain" (show domain) - ~~ field "searchTerm" searchTerm - mFedCnf <- lift $ liftSem $ E.getFederationConfig domain - let onlyInTeams = case restriction <$> mFedCnf of - Just FederationRestrictionAllowAll -> Nothing - Just (FederationRestrictionByTeam teams) -> Just teams - -- if we are not federating at all, we also do not allow to search any remote teams - Nothing -> Just [] - - searchResponse <- Federation.searchUsers domain (FedBrig.SearchRequest searchTerm mTid onlyInTeams) !>> fedError - let contacts = S.contacts searchResponse - let count = length contacts - pure - SearchResult - { searchResults = contacts, - searchFound = count, - searchReturned = count, - searchTook = 0, - searchPolicy = S.searchPolicy searchResponse, - searchPagingState = Nothing, - searchHasMore = Nothing - } - -searchLocally :: - forall r. - ( Member GalleyAPIAccess r, - Member UserSubsystem r, - Member UserStore r - ) => - UserId -> - Text -> - Maybe (Range 1 500 Int32) -> - (Handler r) (Public.SearchResult Public.Contact) -searchLocally searcherId searchTerm maybeMaxResults = do - let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults - searcherTeamId <- lift $ wrapClient $ DB.lookupUserTeam searcherId - teamSearchInfo <- mkTeamSearchInfo searcherTeamId - - maybeExactHandleMatch <- exactHandleSearch - - let exactHandleMatchCount = length maybeExactHandleMatch - esMaxResults = maxResults - exactHandleMatchCount - - esResult <- - if esMaxResults > 0 - then Q.searchIndex (Q.LocalSearch searcherId searcherTeamId teamSearchInfo) searchTerm esMaxResults - else pure $ SearchResult 0 0 0 [] FullSearch Nothing Nothing - - -- Prepend results matching exact handle and results from ES. - pure $ - esResult - { searchResults = maybeToList maybeExactHandleMatch <> searchResults esResult, - searchFound = exactHandleMatchCount + searchFound esResult, - searchReturned = exactHandleMatchCount + searchReturned esResult - } - where - handleTeamVisibility :: TeamId -> TeamSearchVisibility -> Search.TeamSearchInfo - handleTeamVisibility _ SearchVisibilityStandard = Search.AllUsers - handleTeamVisibility t SearchVisibilityNoNameOutsideTeam = Search.TeamOnly t - - mkTeamSearchInfo :: Maybe TeamId -> (Handler r) Search.TeamSearchInfo - mkTeamSearchInfo searcherTeamId = lift $ do - sameTeamSearchOnly <- fromMaybe False <$> view (settings . Opts.searchSameTeamOnly) - case searcherTeamId of - Nothing -> pure Search.NoTeam - Just t -> - -- This flag in brig overrules any flag on galley - it is system wide - if sameTeamSearchOnly - then pure (Search.TeamOnly t) - else do - -- For team users, we need to check the visibility flag - handleTeamVisibility t <$> liftSem (GalleyAPIAccess.getTeamSearchVisibility t) - - exactHandleSearch :: (Handler r) (Maybe Contact) - exactHandleSearch = do - lsearcherId <- qualifyLocal searcherId - case Handle.parseHandle searchTerm of - Nothing -> pure Nothing - Just handle -> do - HandleAPI.contactFromProfile - <$$> HandleAPI.getLocalHandleInfo lsearcherId handle teamUserSearch :: (Member GalleyAPIAccess r) => From 78d88567b2382ed2f161a582d7f482151864bed4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 22 Aug 2024 14:40:50 +0200 Subject: [PATCH 16/48] Move browseTeam to wire-subsystem --- .../src/Wire/API/Routes/Public/Brig.hs | 2 +- .../src/Wire/IndexedUserStore.hs | 18 +- .../Wire/IndexedUserStore/ElasticSearch.hs | 193 +++++++++++++++--- .../src/Wire/UserSearch/Types.hs | 28 +++ .../src/Wire/UserSearchSubsystem.hs | 32 +-- .../Wire/UserSearchSubsystem/Interpreter.hs | 69 +++++-- services/brig/brig.cabal | 7 - services/brig/src/Brig/API/Internal.hs | 2 +- services/brig/src/Brig/API/Public.hs | 19 +- services/brig/src/Brig/Team/Util.hs | 15 -- services/brig/src/Brig/User/API/Search.hs | 50 ----- .../src/Brig/User/Search/TeamUserSearch.hs | 179 ---------------- 12 files changed, 282 insertions(+), 332 deletions(-) delete mode 100644 services/brig/src/Brig/User/API/Search.hs delete mode 100644 services/brig/src/Brig/User/Search/TeamUserSearch.hs diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 44aefdaa88a..023bf276743 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -1380,7 +1380,7 @@ type SearchAPI = Description "Number of results to return (min: 1, max: 500, default: 15)" ] "size" - (Range 1 500 Int32) + (Range 1 500 Int) :> QueryParam' [ Optional, Strict, diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs index c8ab65e43db..c1900b19915 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs @@ -12,11 +12,25 @@ import Wire.UserSearch.Types data IndexedUserStore m a where Upsert :: DocId -> UserDoc -> VersionControl -> IndexedUserStore m () - UpdateTeamSearchVisibilityInbound :: TeamId -> SearchVisibilityInbound -> IndexedUserStore m () + UpdateTeamSearchVisibilityInbound :: + TeamId -> + SearchVisibilityInbound -> + IndexedUserStore m () -- | Will only be applied to main ES index and not the additional one BulkUpsert :: [(DocId, UserDoc, VersionControl)] -> IndexedUserStore m () DoesIndexExist :: IndexedUserStore m Bool - SearchUsers :: UserId -> Maybe TeamId -> TeamSearchInfo -> Text -> Int -> IndexedUserStore m (SearchResult UserDoc) + SearchUsers :: + UserId -> + Maybe TeamId -> + TeamSearchInfo -> + Text -> + Int -> + IndexedUserStore m (SearchResult UserDoc) + PaginateTeamMembers :: + BrowseTeamFilters -> + Int -> + Maybe PagingState -> + IndexedUserStore m (SearchResult UserDoc) makeSem ''IndexedUserStore diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index f8dc770a679..a2bf68148d5 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -1,12 +1,17 @@ +{-# LANGUAGE RecordWildCards #-} + module Wire.IndexedUserStore.ElasticSearch where +import Control.Error (lastMay) import Control.Exception (throwIO) import Data.Aeson import Data.Aeson.Key qualified as Key +import Data.ByteString qualified as LBS import Data.ByteString.Builder import Data.ByteString.Conversion import Data.Id import Data.Text qualified as Text +import Data.Text.Ascii import Data.Text.Encoding qualified as Text import Database.Bloodhound qualified as ES import Imports @@ -48,10 +53,14 @@ interpretIndexedUserStoreES :: interpretIndexedUserStoreES cfg = interpret $ \case Upsert docId userDoc versioning -> upsertImpl cfg docId userDoc versioning - UpdateTeamSearchVisibilityInbound tid vis -> updateTeamSearchVisibilityInboundImpl cfg tid vis + UpdateTeamSearchVisibilityInbound tid vis -> + updateTeamSearchVisibilityInboundImpl cfg tid vis BulkUpsert docs -> bulkUpsertImpl cfg docs DoesIndexExist -> doesIndexExistImpl cfg - SearchUsers searcherId mSearcherTeam teamSearchInfo term maxResults -> searchUsersImpl cfg searcherId mSearcherTeam teamSearchInfo term maxResults + SearchUsers searcherId mSearcherTeam teamSearchInfo term maxResults -> + searchUsersImpl cfg searcherId mSearcherTeam teamSearchInfo term maxResults + PaginateTeamMembers filters maxResults mPagingState -> + paginateTeamMembersImpl cfg filters maxResults mPagingState upsertImpl :: forall r. @@ -166,32 +175,6 @@ searchUsersImpl cfg searcherId mSearcherTeam teamSearchInfo term maxResults = queryIndex cfg maxResults $ defaultUserQuery searcherId mSearcherTeam teamSearchInfo term -queryIndex :: - (Member (Embed IO) r) => - IndexedUserStoreConfig -> - Int -> - IndexQuery x -> - Sem r (SearchResult UserDoc) -queryIndex cfg s (IndexQuery q f _) = do - -- localDomain <- viewFederationDomain - let search = (ES.mkSearch (Just q) (Just f)) {ES.size = ES.Size (fromIntegral s)} - r <- ES.runBH cfg.conn.env $ do - res <- ES.searchByType cfg.conn.indexName mappingName search - liftIO $ ES.parseEsResponse @_ @(ES.SearchResult UserDoc) res - either (embed . throwIO . IndexLookupError) (pure . mkResult) r - where - mkResult es = - let results = mapMaybe ES.hitSource . ES.hits . ES.searchHits $ es - in SearchResult - { searchFound = ES.hitsTotal . ES.searchHits $ es, - searchReturned = length results, - searchTook = ES.took es, - searchResults = results, - searchPolicy = FullSearch, - searchPagingState = Nothing, - searchHasMore = Nothing - } - -- | The default or canonical 'IndexQuery'. -- -- The intention behind parameterising 'queryIndex' over the 'IndexQuery' is that @@ -237,6 +220,160 @@ defaultUserQuery searcher mSearcherTeamId teamSearchInfo (normalized -> term') = } in mkUserQuery searcher mSearcherTeamId teamSearchInfo queryWithBoost +paginateTeamMembersImpl :: + (Member (Embed IO) r) => + IndexedUserStoreConfig -> + BrowseTeamFilters -> + Int -> + Maybe PagingState -> + Sem r (SearchResult UserDoc) +paginateTeamMembersImpl cfg BrowseTeamFilters {..} maxResults mPagingState = do + let (IndexQuery q f sortSpecs) = + teamUserSearchQuery teamId mQuery mRoleFilter mSortBy mSortOrder + let search = + (ES.mkSearch (Just q) (Just f)) + { -- we are requesting one more result than the page size to determine if there is a next page + ES.size = ES.Size (fromIntegral maxResults + 1), + ES.sortBody = Just (fmap ES.DefaultSortSpec sortSpecs), + ES.searchAfterKey = toSearchAfterKey =<< mPagingState + } + mkResult <$> searchInMainIndex cfg search + where + toSearchAfterKey ps = decode' . LBS.fromStrict =<< (decodeBase64Url . unPagingState) ps + + fromSearchAfterKey :: ES.SearchAfterKey -> PagingState + fromSearchAfterKey = PagingState . encodeBase64Url . LBS.toStrict . encode + + mkResult es = + let hitsPlusOne = ES.hits . ES.searchHits $ es + hits = take (fromIntegral maxResults) hitsPlusOne + mps = fromSearchAfterKey <$> lastMay (mapMaybe ES.hitSort hits) + results = mapMaybe ES.hitSource hits + in SearchResult + { searchFound = ES.hitsTotal . ES.searchHits $ es, + searchReturned = length results, + searchTook = ES.took es, + searchResults = results, + searchPolicy = FullSearch, + searchPagingState = mps, + searchHasMore = Just $ length hitsPlusOne > length hits + } + +searchInMainIndex :: forall r. (Member (Embed IO) r) => IndexedUserStoreConfig -> ES.Search -> Sem r (ES.SearchResult UserDoc) +searchInMainIndex cfg search = do + r <- ES.runBH cfg.conn.env $ do + res <- ES.searchByType cfg.conn.indexName mappingName search + liftIO $ ES.parseEsResponse res + either (embed . throwIO . IndexLookupError) pure r + +queryIndex :: + (Member (Embed IO) r) => + IndexedUserStoreConfig -> + Int -> + IndexQuery x -> + Sem r (SearchResult UserDoc) +queryIndex cfg s (IndexQuery q f _) = do + let search = (ES.mkSearch (Just q) (Just f)) {ES.size = ES.Size (fromIntegral s)} + mkResult <$> searchInMainIndex cfg search + where + mkResult es = + let results = mapMaybe ES.hitSource . ES.hits . ES.searchHits $ es + in SearchResult + { searchFound = ES.hitsTotal . ES.searchHits $ es, + searchReturned = length results, + searchTook = ES.took es, + searchResults = results, + searchPolicy = FullSearch, + searchPagingState = Nothing, + searchHasMore = Nothing + } + +teamUserSearchQuery :: + TeamId -> + Maybe Text -> + Maybe RoleFilter -> + Maybe TeamUserSearchSortBy -> + Maybe TeamUserSearchSortOrder -> + IndexQuery TeamContact +teamUserSearchQuery tid mbSearchText _mRoleFilter mSortBy mSortOrder = + IndexQuery + ( maybe + (ES.MatchAllQuery Nothing) + matchPhraseOrPrefix + mbQStr + ) + teamFilter + -- in combination with pagination a non-unique search specification can lead to missing results + -- therefore we use the unique `_doc` value as a tie breaker + -- - see https://www.elastic.co/guide/en/elasticsearch/reference/6.8/search-request-sort.html for details on `_doc` + -- - see https://www.elastic.co/guide/en/elasticsearch/reference/6.8/search-request-search-after.html for details on pagination and tie breaker + -- in the latter article it "is advised to duplicate (client side or [...]) the content of the _id field + -- in another field that has doc value enabled and to use this new field as the tiebreaker for the sort" + -- so alternatively we could use the user ID as a tie breaker, but this would require a change in the index mapping + (sorting ++ sortingTieBreaker) + where + sorting :: [ES.DefaultSort] + sorting = + maybe + [defaultSort SortByCreatedAt SortOrderDesc | isNothing mbQStr] + (\tuSortBy -> [defaultSort tuSortBy (fromMaybe SortOrderAsc mSortOrder)]) + mSortBy + sortingTieBreaker :: [ES.DefaultSort] + sortingTieBreaker = [ES.DefaultSort (ES.FieldName "_doc") ES.Ascending Nothing Nothing Nothing Nothing] + + mbQStr :: Maybe Text + mbQStr = + case mbSearchText of + Nothing -> Nothing + Just q -> + case normalized q of + "" -> Nothing + term' -> Just term' + + matchPhraseOrPrefix term' = + ES.QueryMultiMatchQuery $ + ( ES.mkMultiMatchQuery + [ ES.FieldName "email^4", + ES.FieldName "handle^4", + ES.FieldName "normalized^3", + ES.FieldName "email.prefix^3", + ES.FieldName "handle.prefix^2", + ES.FieldName "normalized.prefix" + ] + (ES.QueryString term') + ) + { ES.multiMatchQueryType = Just ES.MultiMatchMostFields, + ES.multiMatchQueryOperator = ES.And + } + + teamFilter = + ES.Filter $ + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = [ES.TermQuery (ES.Term "team" $ idToText tid) Nothing] + } + + defaultSort :: TeamUserSearchSortBy -> TeamUserSearchSortOrder -> ES.DefaultSort + defaultSort tuSortBy sortOrder = + ES.DefaultSort + ( case tuSortBy of + SortByName -> ES.FieldName "name" + SortByHandle -> ES.FieldName "handle.keyword" + SortByEmail -> ES.FieldName "email.keyword" + SortBySAMLIdp -> ES.FieldName "saml_idp" + SortByManagedBy -> ES.FieldName "managed_by" + SortByRole -> ES.FieldName "role" + SortByCreatedAt -> ES.FieldName "created_at" + ) + ( case sortOrder of + SortOrderAsc -> ES.Ascending + SortOrderDesc -> ES.Descending + ) + Nothing + Nothing + Nothing + Nothing + mkUserQuery :: UserId -> Maybe TeamId -> TeamSearchInfo -> ES.Query -> IndexQuery Contact mkUserQuery searcher mSearcherTeamId teamSearchInfo q = IndexQuery diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs index 7761def2b90..0dbd0df1c5a 100644 --- a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs +++ b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Wire.UserSearch.Types where import Cassandra qualified as C @@ -107,6 +109,24 @@ instance FromJSON UserDoc where searchVisibilityInboundFieldName :: Key searchVisibilityInboundFieldName = "search_visibility_inbound" +userDocToTeamContact :: UserDoc -> TeamContact +userDocToTeamContact UserDoc {..} = + TeamContact + { teamContactUserId = udId, + teamContactTeam = udTeam, + teamContactSso = udSso, + teamContactScimExternalId = udScimExternalId, + teamContactSAMLIdp = udSAMLIdP, + teamContactRole = udRole, + teamContactName = maybe "" fromName udName, + teamContactManagedBy = udManagedBy, + teamContactHandle = fromHandle <$> udHandle, + teamContactEmailUnvalidated = udEmailUnvalidated, + teamContactEmail = udEmail, + teamContactCreatedAt = udCreatedAt, + teamContactColorId = fromIntegral . fromColourId <$> udColourId + } + -- | Outbound search restrictions configured by team admin of the searcher. This -- value restricts the set of user that are searched. -- @@ -176,3 +196,11 @@ instance FromJSON SearchVisibilityInbound where Right result -> pure result data IndexQuery r = IndexQuery Query Filter [DefaultSort] + +data BrowseTeamFilters = BrowseTeamFilters + { teamId :: TeamId, + mQuery :: Maybe Text, + mRoleFilter :: Maybe RoleFilter, + mSortBy :: Maybe TeamUserSearchSortBy, + mSortOrder :: Maybe TeamUserSearchSortOrder + } diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs index 84bf74bed2b..d8b3b702554 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs @@ -11,39 +11,21 @@ import Polysemy import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) import Wire.API.Team.Feature import Wire.API.User.Search - -data BrowseTeamFilters = BrowseTeamFilters - { teamId :: TeamId, - mQuery :: Maybe Text, - mRoleFilter :: Maybe RoleFilter, - mSortBy :: Maybe TeamUserSearchSortBy, - mSortOrder :: Maybe TeamUserSearchSortOrder - } +import Wire.UserSearch.Types data UserSearchSubsystem m a where SyncUser :: UserId -> UserSearchSubsystem m () UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSearchSubsystem m () SearchUsers :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m (SearchResult Contact) - BrowseTeam :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> UserSearchSubsystem m [TeamContact] + BrowseTeam :: + UserId -> + BrowseTeamFilters -> + Maybe (Range 1 500 Int) -> + Maybe PagingState -> + UserSearchSubsystem m (SearchResult TeamContact) makeSem ''UserSearchSubsystem --- | This function exists because there are a lot query params and they cannot all become 'BrowseTeamFilters' automatically -browseTeamHandler :: - (Member UserSearchSubsystem r) => - UserId -> - TeamId -> - Maybe Text -> - Maybe RoleFilter -> - Maybe TeamUserSearchSortBy -> - Maybe TeamUserSearchSortOrder -> - Maybe (Range 1 500 Int32) -> - Maybe PagingState -> - Sem r [TeamContact] -browseTeamHandler uid tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder mMaxResults mPagingState = do - let browseTeamFilters = BrowseTeamFilters tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder - browseTeam uid browseTeamFilters mMaxResults mPagingState - -- | Bulk operations, must not be used from any web handler data UserSearchSubsystemBulk m a where -- | Only changes data if it is not updated since last update, use when users diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index 9541a725312..a5b5ea8211b 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Wire.UserSearchSubsystem.Interpreter where import Cassandra.Exec (paginateWithStateC) @@ -11,7 +13,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range import Data.Set qualified as Set -import Database.Bloodhound.Types qualified as ES +import Database.Bloodhound qualified as ES import Imports import Polysemy import Polysemy.Error @@ -26,6 +28,7 @@ import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) import Wire.API.Team.Feature import Wire.API.Team.Member +import Wire.API.Team.Permission qualified as Permission import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Search @@ -66,10 +69,13 @@ interpretUserSearchSubsystem :: UserSubsystemConfig -> InterpreterFor UserSearchSubsystem r interpretUserSearchSubsystem config = interpret \case - SyncUser uid -> syncUserImpl uid - UpdateTeamSearchVisibilityInbound status -> updateTeamSearchVisibilityInboundImpl status - SearchUsers luid query mDomain mMaxResults -> searchUsersImpl config luid query mDomain mMaxResults - BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> do + SyncUser uid -> + syncUserImpl uid + UpdateTeamSearchVisibilityInbound status -> + updateTeamSearchVisibilityInboundImpl status + SearchUsers luid query mDomain mMaxResults -> + searchUsersImpl config luid query mDomain mMaxResults + BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> browseTeamImpl uid browseTeamFilters mMaxResults mPagingState interpretUserSearchSubsystemBulk :: @@ -197,11 +203,6 @@ searchUsersImpl :: Maybe (Range 1 500 Int32) -> Sem r (SearchResult Contact) searchUsersImpl config searcherId searchTerm maybeDomain maybeMaxResults = do - -- FUTUREWORK(fisx): to reduce cassandra traffic, 'ensurePermissionsOrPersonalUser' could be - -- run from `searchLocally` and `searchRemotely`, resp., where the team id is already - -- available (at least in the local case) and can be passed as an argument rather than - -- looked up again. - -- user <- fromMaybe (error "TODO: searcher is not real") <$> UserSubsystem.getLocalUser searcherId storedSearcher <- fromMaybe (error "TODO: searcher is not real") <$> UserStore.getUser (tUnqualified searcherId) for_ storedSearcher.teamId $ \tid -> ensurePermissions (tUnqualified searcherId) tid [SearchContacts] let localDomain = tDomain searcherId @@ -209,16 +210,6 @@ searchUsersImpl config searcherId searchTerm maybeDomain maybeMaxResults = do if queryDomain == localDomain then searchLocally config (qualifyAs searcherId storedSearcher) searchTerm maybeMaxResults else searchRemotely queryDomain storedSearcher.teamId searchTerm - where - ensurePermissions :: (IsPerm perm) => UserId -> TeamId -> [perm] -> Sem r () - ensurePermissions u t perms = do - m <- GalleyAPIAccess.getTeamMember u t - unless (check m) $ - throw UserSubsystemInsufficientTeamPermissions - where - check :: Maybe TeamMember -> Bool - check (Just m) = all (hasPermission m) perms - check Nothing = False searchLocally :: forall r. @@ -349,8 +340,24 @@ searchRemotely domain mTid searchTerm = do searchHasMore = Nothing } -browseTeamImpl :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> Sem r [TeamContact] -browseTeamImpl = undefined +browseTeamImpl :: + ( Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r, + Member IndexedUserStore r + ) => + UserId -> + BrowseTeamFilters -> + Maybe (Range 1 500 Int) -> + Maybe PagingState -> + Sem r (SearchResult TeamContact) +browseTeamImpl uid filters mMaxResults mPagingState = do + -- limit this to team admins to reduce risk of involuntary DOS attacks. (also, + -- this way we don't need to worry about revealing confidential user data to + -- other team members.) + ensurePermissions uid filters.teamId [Permission.AddTeamMember] + + let maxResults = maybe 15 fromRange mMaxResults + userDocToTeamContact <$$> IndexedUserStore.paginateTeamMembers filters maxResults mPagingState migrateDataImpl :: ( Member IndexedUserStore r, @@ -392,3 +399,21 @@ teamSearchVisibilityInbound :: (Member GalleyAPIAccess r) => TeamId -> Sem r Sea teamSearchVisibilityInbound tid = searchVisibilityInboundFromFeatureStatus . (.status) <$> getFeatureConfigForTeam @_ @SearchVisibilityInboundConfig tid + +ensurePermissions :: + ( IsPerm perm, + Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r + ) => + UserId -> + TeamId -> + [perm] -> + Sem r () +ensurePermissions u t perms = do + m <- GalleyAPIAccess.getTeamMember u t + unless (check m) $ + throw UserSubsystemInsufficientTeamPermissions + where + check :: Maybe TeamMember -> Bool + check (Just m) = all (hasPermission m) perms + check Nothing = False diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index b54d1509c0d..c833f42fc9a 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -190,7 +190,6 @@ library Brig.Team.Util Brig.Template Brig.User.API.Handle - Brig.User.API.Search Brig.User.Auth Brig.User.Auth.Cookie Brig.User.Auth.Cookie.Limit @@ -198,12 +197,10 @@ library Brig.User.Search.Index Brig.User.Search.SearchIndex Brig.User.Search.TeamSize - Brig.User.Search.TeamUserSearch Brig.User.Template Brig.Version Brig.ZAuth - other-modules: Paths_brig hs-source-dirs: src ghc-options: -funbox-strict-fields -fplugin=Polysemy.Plugin @@ -331,13 +328,11 @@ library executable brig import: common-all main-is: exec/Main.hs - other-modules: Paths_brig ghc-options: -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts -Wredundant-constraints -Wunused-packages build-depends: - , base , brig , HsOpenSSL , imports @@ -346,7 +341,6 @@ executable brig executable brig-index import: common-all main-is: index/src/Main.hs - other-modules: Paths_brig ghc-options: -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: , base @@ -497,7 +491,6 @@ executable brig-schema ghc-options: -funbox-strict-fields -Wredundant-constraints -threaded default-extensions: TemplateHaskell build-depends: - , base , brig , cassandra-util , extended diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index f4b08922933..c43ee03d060 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -48,8 +48,8 @@ import Brig.Types.Connection import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User -import Brig.User.API.Search qualified as Search import Brig.User.EJPD qualified +import Brig.User.Search.Index qualified as Search import Control.Error hiding (bool) import Control.Lens (preview, to, view, _Just) import Data.ByteString.Conversion (toByteString) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 94dfcbe3fc5..ea45957bb5e 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -54,7 +54,6 @@ import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra (UserAccount (UserAccount, accountUser)) import Brig.Types.User (HavePendingInvitations (..)) import Brig.User.API.Handle qualified as Handle -import Brig.User.API.Search (teamUserSearch) import Brig.User.Auth.Cookie qualified as Auth import Cassandra qualified as C import Cassandra qualified as Data @@ -160,6 +159,7 @@ import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore +import Wire.UserSearch.Types import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserSearchSubsystem qualified as UserSearchSubsystem import Wire.UserStore (UserStore) @@ -425,7 +425,7 @@ servantSitemap = searchAPI :: ServerT SearchAPI (Handler r) searchAPI = - Named @"browse-team" teamUserSearch + Named @"browse-team" browseTeamHandler authAPI :: ServerT AuthAPI (Handler r) authAPI = @@ -457,6 +457,21 @@ servantSitemap = --------------------------------------------------------------------------- -- Handlers +browseTeamHandler :: + (Member UserSearchSubsystem r) => + UserId -> + TeamId -> + Maybe Text -> + Maybe Public.RoleFilter -> + Maybe Public.TeamUserSearchSortBy -> + Maybe Public.TeamUserSearchSortOrder -> + Maybe (Range 1 500 Int) -> + Maybe Public.PagingState -> + Handler r (Public.SearchResult Public.TeamContact) +browseTeamHandler uid tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder mMaxResults mPagingState = do + let browseTeamFilters = BrowseTeamFilters tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder + lift . liftSem $ UserSearchSubsystem.browseTeam uid browseTeamFilters mMaxResults mPagingState + setPropertyH :: (Member PropertySubsystem r) => UserId -> ConnId -> Public.PropertyKey -> Public.RawPropertyValue -> Handler r () setPropertyH u c key raw = lift . liftSem $ setProperty u c key raw diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index cec7f81351e..428c9abaf98 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -19,8 +19,6 @@ module Brig.Team.Util where -- TODO: remove this module and move contents to Bri import Brig.API.Error import Brig.App -import Brig.Data.User qualified as Data -import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error import Control.Lens import Data.Id @@ -29,23 +27,10 @@ import Imports import Polysemy (Member) import Wire.API.Team.Member import Wire.API.Team.Permission -import Wire.API.User (User (userTeam)) import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess --- TODO(md): remove ensurePermissionsOrPersonalUser as it's been moved to an --- interpreter --- - --- | If the user is in a team, it has to have these permissions. If not, it is a personal --- user with account validation and thus given the permission implicitly. (Used for --- `SearchContactcs`.) -ensurePermissionsOrPersonalUser :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> [perm] -> ExceptT HttpError (AppT r) () -ensurePermissionsOrPersonalUser u perms = do - mbUser <- lift $ wrapHttp $ Data.lookupUser NoPendingInvitations u - maybe (pure ()) (\tid -> ensurePermissions u tid perms) (userTeam =<< mbUser :: Maybe TeamId) - ensurePermissions :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> TeamId -> [perm] -> ExceptT HttpError (AppT r) () ensurePermissions u t perms = do m <- lift $ liftSem $ GalleyAPIAccess.getTeamMember u t diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs deleted file mode 100644 index fffd55d37b3..00000000000 --- a/services/brig/src/Brig/User/API/Search.hs +++ /dev/null @@ -1,50 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.User.API.Search - ( teamUserSearch, - refreshIndex, - ) -where - -import Brig.API.Handler -import Brig.Team.Util (ensurePermissions) -import Brig.User.Search.Index -import Brig.User.Search.TeamUserSearch qualified as Q -import Data.Id -import Data.Range -import Imports -import Polysemy -import Wire.API.Team.Permission qualified as Public -import Wire.API.User.Search -import Wire.API.User.Search qualified as Public -import Wire.GalleyAPIAccess (GalleyAPIAccess) - -teamUserSearch :: - (Member GalleyAPIAccess r) => - UserId -> - TeamId -> - Maybe Text -> - Maybe RoleFilter -> - Maybe TeamUserSearchSortBy -> - Maybe TeamUserSearchSortOrder -> - Maybe (Range 1 500 Int32) -> - Maybe PagingState -> - (Handler r) (Public.SearchResult Public.TeamContact) -teamUserSearch uid tid mQuery mRoleFilter mSortBy mSortOrder size mPagingState = do - ensurePermissions uid tid [Public.AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks. (also, this way we don't need to worry about revealing confidential user data to other team members.) - Q.teamUserSearch tid mQuery mRoleFilter mSortBy mSortOrder (fromMaybe (unsafeRange 15) size) mPagingState diff --git a/services/brig/src/Brig/User/Search/TeamUserSearch.hs b/services/brig/src/Brig/User/Search/TeamUserSearch.hs deleted file mode 100644 index c071094c6da..00000000000 --- a/services/brig/src/Brig/User/Search/TeamUserSearch.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE StrictData #-} -{-# OPTIONS_GHC -Wno-orphans #-} --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.User.Search.TeamUserSearch - ( teamUserSearch, - teamUserSearchQuery, - TeamUserSearchSortBy (..), - TeamUserSearchSortOrder (..), - RoleFilter (..), - ) -where - -import Brig.User.Search.Index -import Control.Error (lastMay) -import Control.Monad.Catch (MonadThrow (throwM)) -import Data.Aeson (decode', encode) -import Data.ByteString (fromStrict, toStrict) -import Data.Id (TeamId, idToText) -import Data.Range (Range (..)) -import Data.Text.Ascii (decodeBase64Url, encodeBase64Url) -import Database.Bloodhound qualified as ES -import Imports hiding (log, searchable) -import Wire.API.User.Search --- TODO: importing interpreters is not ideal -import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..), mappingName) -import Wire.UserSearch.Types (IndexQuery (..)) -import Wire.UserStore.IndexUser (normalized) - -teamUserSearch :: - (HasCallStack, MonadIndexIO m) => - TeamId -> - Maybe Text -> - Maybe RoleFilter -> - Maybe TeamUserSearchSortBy -> - Maybe TeamUserSearchSortOrder -> - Range 1 500 Int32 -> - Maybe PagingState -> - m (SearchResult TeamContact) -teamUserSearch tid mbSearchText mRoleFilter mSortBy mSortOrder (fromRange -> size) mPagingState = liftIndexIO $ do - let (IndexQuery q f sortSpecs) = teamUserSearchQuery tid mbSearchText mRoleFilter mSortBy mSortOrder - idx <- asks idxName - let search = - (ES.mkSearch (Just q) (Just f)) - { -- we are requesting one more result than the page size to determine if there is a next page - ES.size = ES.Size (fromIntegral size + 1), - ES.sortBody = Just (fmap ES.DefaultSortSpec sortSpecs), - ES.searchAfterKey = toSearchAfterKey =<< mPagingState - } - r <- - ES.searchByType idx mappingName search - >>= ES.parseEsResponse - either (throwM . IndexLookupError) (pure . mkResult) r - where - toSearchAfterKey :: PagingState -> Maybe ES.SearchAfterKey - toSearchAfterKey ps = decode' . fromStrict =<< (decodeBase64Url . unPagingState $ ps) - - fromSearchAfterKey :: ES.SearchAfterKey -> PagingState - fromSearchAfterKey = PagingState . encodeBase64Url . toStrict . encode - - mkResult es = - let hitsPlusOne = ES.hits . ES.searchHits $ es - hits = take (fromIntegral size) hitsPlusOne - mps = fromSearchAfterKey <$> lastMay (mapMaybe ES.hitSort hits) - results = mapMaybe ES.hitSource hits - in SearchResult - { searchFound = ES.hitsTotal . ES.searchHits $ es, - searchReturned = length results, - searchTook = ES.took es, - searchResults = results, - searchPolicy = FullSearch, - searchPagingState = mps, - searchHasMore = Just $ length hitsPlusOne > length hits - } - --- FUTURWORK: Implement role filter (needs galley data) -teamUserSearchQuery :: - TeamId -> - Maybe Text -> - Maybe RoleFilter -> - Maybe TeamUserSearchSortBy -> - Maybe TeamUserSearchSortOrder -> - IndexQuery TeamContact -teamUserSearchQuery tid mbSearchText _mRoleFilter mSortBy mSortOrder = - IndexQuery - ( maybe - (ES.MatchAllQuery Nothing) - matchPhraseOrPrefix - mbQStr - ) - teamFilter - -- in combination with pagination a non-unique search specification can lead to missing results - -- therefore we use the unique `_doc` value as a tie breaker - -- - see https://www.elastic.co/guide/en/elasticsearch/reference/6.8/search-request-sort.html for details on `_doc` - -- - see https://www.elastic.co/guide/en/elasticsearch/reference/6.8/search-request-search-after.html for details on pagination and tie breaker - -- in the latter article it "is advised to duplicate (client side or [...]) the content of the _id field - -- in another field that has doc value enabled and to use this new field as the tiebreaker for the sort" - -- so alternatively we could use the user ID as a tie breaker, but this would require a change in the index mapping - (sorting ++ sortingTieBreaker) - where - sorting :: [ES.DefaultSort] - sorting = - maybe - [defaultSort SortByCreatedAt SortOrderDesc | isNothing mbQStr] - (\tuSortBy -> [defaultSort tuSortBy (fromMaybe SortOrderAsc mSortOrder)]) - mSortBy - sortingTieBreaker :: [ES.DefaultSort] - sortingTieBreaker = [ES.DefaultSort (ES.FieldName "_doc") ES.Ascending Nothing Nothing Nothing Nothing] - - mbQStr :: Maybe Text - mbQStr = - case mbSearchText of - Nothing -> Nothing - Just q -> - case normalized q of - "" -> Nothing - term' -> Just term' - - matchPhraseOrPrefix term' = - ES.QueryMultiMatchQuery $ - ( ES.mkMultiMatchQuery - [ ES.FieldName "email^4", - ES.FieldName "handle^4", - ES.FieldName "normalized^3", - ES.FieldName "email.prefix^3", - ES.FieldName "handle.prefix^2", - ES.FieldName "normalized.prefix" - ] - (ES.QueryString term') - ) - { ES.multiMatchQueryType = Just ES.MultiMatchMostFields, - ES.multiMatchQueryOperator = ES.And - } - - teamFilter = - ES.Filter $ - ES.QueryBoolQuery - boolQuery - { ES.boolQueryMustMatch = [ES.TermQuery (ES.Term "team" $ idToText tid) Nothing] - } - - defaultSort :: TeamUserSearchSortBy -> TeamUserSearchSortOrder -> ES.DefaultSort - defaultSort tuSortBy sortOrder = - ES.DefaultSort - ( case tuSortBy of - SortByName -> ES.FieldName "name" - SortByHandle -> ES.FieldName "handle.keyword" - SortByEmail -> ES.FieldName "email.keyword" - SortBySAMLIdp -> ES.FieldName "saml_idp" - SortByManagedBy -> ES.FieldName "managed_by" - SortByRole -> ES.FieldName "role" - SortByCreatedAt -> ES.FieldName "created_at" - ) - ( case sortOrder of - SortOrderAsc -> ES.Ascending - SortOrderDesc -> ES.Descending - ) - Nothing - Nothing - Nothing - Nothing From 4ad948ff2f31c0918eaa12db2d43608bf4a21765 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 26 Aug 2024 16:46:09 +0200 Subject: [PATCH 17/48] wire-subsystems: Fix compile errors with MiniBackend Also accomodates some changes from future commits --- .../src/Wire/FederationConfigStore.hs | 2 ++ .../test/unit/Wire/MiniBackend.hs | 10 ++++++ .../test/unit/Wire/MockInterpreters.hs | 2 ++ .../MockInterpreters/FederationConfigStore.hs | 31 +++++++++++++++++++ .../Wire/MockInterpreters/IndexedUserStore.hs | 15 +++++++++ libs/wire-subsystems/wire-subsystems.cabal | 2 ++ 6 files changed, 62 insertions(+) create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs diff --git a/libs/wire-subsystems/src/Wire/FederationConfigStore.hs b/libs/wire-subsystems/src/Wire/FederationConfigStore.hs index c043af54184..8b9bee0f9bf 100644 --- a/libs/wire-subsystems/src/Wire/FederationConfigStore.hs +++ b/libs/wire-subsystems/src/Wire/FederationConfigStore.hs @@ -24,6 +24,8 @@ data AddFederationRemoteTeamResult | AddFederationRemoteTeamDomainNotFound | AddFederationRemoteTeamRestrictionAllowAll +-- TODO: This store effect is more than just a store, we should break it up in +-- business logic and store data FederationConfigStore m a where GetFederationConfig :: Domain -> FederationConfigStore m (Maybe FederationDomainConfig) GetFederationConfigs :: FederationConfigStore m FederationDomainConfigs diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index bd712dfe489..fb4c6c963f4 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -58,12 +58,16 @@ import Wire.DeleteQueue.InMemory import Wire.Events import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter as FI +import Wire.FederationConfigStore import Wire.GalleyAPIAccess +import Wire.IndexedUserStore import Wire.InternalEvent hiding (DeleteUser) import Wire.MockInterpreters import Wire.PasswordResetCodeStore import Wire.Sem.Concurrency import Wire.Sem.Concurrency.Sequential +import Wire.Sem.Metrics +import Wire.Sem.Metrics.IO (ignoreMetrics) import Wire.Sem.Now hiding (get) import Wire.StoredUser import Wire.UserKeyStore @@ -103,6 +107,8 @@ type MiniBackendEffects = State [StoredUser], UserKeyStore, State (Map EmailKey UserId), + IndexedUserStore, + FederationConfigStore, DeleteQueue, Events, State [InternalNotification], @@ -111,6 +117,7 @@ type MiniBackendEffects = Now, Input UserSubsystemConfig, Input (Local ()), + Metrics, FederationAPIAccess MiniFederationMonad, TinyLog, Concurrency 'Unsafe @@ -338,6 +345,7 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem sequentiallyPerformConcurrency . noOpLogger . maybeFederationAPIAccess + . ignoreMetrics . runInputConst (toLocalUnsafe (Domain "localdomain") ()) . runInputConst cfg . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) @@ -346,6 +354,8 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem . evalState [] . miniEventInterpreter . inMemoryDeleteQueueInterpreter + . runFederationConfigStoreInMemory + . inMemoryIndexedUserStoreInterpreter . liftUserKeyStoreState . inMemoryUserKeyStoreInterpreter . liftUserStoreState diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs index ebd8d4d1ee5..e975ac6a06c 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs @@ -7,8 +7,10 @@ import Wire.MockInterpreters.BlockListStore as MockInterpreters import Wire.MockInterpreters.EmailSubsystem as MockInterpreters import Wire.MockInterpreters.Error as MockInterpreters import Wire.MockInterpreters.Events as MockInterpreters +import Wire.MockInterpreters.FederationConfigStore as MockInterpreters import Wire.MockInterpreters.GalleyAPIAccess as MockInterpreters import Wire.MockInterpreters.HashPassword as MockInterpreters +import Wire.MockInterpreters.IndexedUserStore as MockInterpreters import Wire.MockInterpreters.Now as MockInterpreters import Wire.MockInterpreters.PasswordResetCodeStore as MockInterpreters import Wire.MockInterpreters.PasswordStore as MockInterpreters diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs new file mode 100644 index 00000000000..647a2139dc3 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs @@ -0,0 +1,31 @@ +module Wire.MockInterpreters.FederationConfigStore where + +import Imports +import Polysemy +import Polysemy.State +import Wire.API.Routes.FederationDomainConfig +import Wire.FederationConfigStore + +inMemoryFederationConfigStoreInterpreter :: + (Member (State [FederationDomainConfig]) r) => + InterpreterFor FederationConfigStore r +inMemoryFederationConfigStoreInterpreter = + interpret $ \case + GetFederationConfig domain -> gets $ find (\cfg -> cfg.domain == domain) + GetFederationConfigs -> do + remoteConfigs <- get + pure $ FederationDomainConfigs AllowDynamic remoteConfigs 1 + AddFederationConfig newCfg -> do + modify $ (newCfg :) . deleteBy (\a b -> a.domain == b.domain) newCfg + pure AddFederationRemoteSuccess + UpdateFederationConfig cfg -> undefined cfg + AddFederationRemoteTeam domain team -> undefined domain team + RemoveFederationRemoteTeam domain team -> undefined domain team + GetFederationRemoteTeams domain -> undefined domain + BackendFederatesWith remoteMaybeTeam -> undefined remoteMaybeTeam + +runFederationConfigStoreInMemory :: InterpreterFor FederationConfigStore r +runFederationConfigStoreInMemory = + evalState [] + . inMemoryFederationConfigStoreInterpreter + . raiseUnder diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs new file mode 100644 index 00000000000..70f80eb2a2c --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs @@ -0,0 +1,15 @@ +module Wire.MockInterpreters.IndexedUserStore where + +import Imports +import Polysemy +import Wire.IndexedUserStore + +inMemoryIndexedUserStoreInterpreter :: InterpreterFor IndexedUserStore r +inMemoryIndexedUserStoreInterpreter = + interpret $ \case + Upsert {} -> error "IndexedUserStore: unimplemented in memory interpreter" + UpdateTeamSearchVisibilityInbound {} -> error "IndexedUserStore: unimplemented in memory interpreter" + BulkUpsert {} -> error "IndexedUserStore: unimplemented in memory interpreter" + DoesIndexExist -> error "IndexedUserStore: unimplemented in memory interpreter" + SearchUsers {} -> error "IndexedUserStore: unimplemented in memory interpreter" + PaginateTeamMembers {} -> error "IndexedUserStore: unimplemented in memory interpreter" diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 4e14ae0c000..d22f373cf27 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -229,8 +229,10 @@ test-suite wire-subsystems-tests Wire.MockInterpreters.EmailSubsystem Wire.MockInterpreters.Error Wire.MockInterpreters.Events + Wire.MockInterpreters.FederationConfigStore Wire.MockInterpreters.GalleyAPIAccess Wire.MockInterpreters.HashPassword + Wire.MockInterpreters.IndexedUserStore Wire.MockInterpreters.Now Wire.MockInterpreters.PasswordResetCodeStore Wire.MockInterpreters.PasswordStore From 67a361706ad0edb3a77bc6ce80d1b398d643b820 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 26 Aug 2024 16:53:03 +0200 Subject: [PATCH 18/48] Merge UserSearchSubsystem into UserSubsystem --- .../src/Wire/UserSearch/Types.hs | 3 + .../src/Wire/UserSearchSubsystem.hs | 22 -- .../Wire/UserSearchSubsystem/Interpreter.hs | 290 +---------------- .../wire-subsystems/src/Wire/UserSubsystem.hs | 17 + .../src/Wire/UserSubsystem/Interpreter.hs | 306 +++++++++++++++++- 5 files changed, 319 insertions(+), 319 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs index 0dbd0df1c5a..8bc636aea51 100644 --- a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs +++ b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs @@ -204,3 +204,6 @@ data BrowseTeamFilters = BrowseTeamFilters mSortBy :: Maybe TeamUserSearchSortBy, mSortOrder :: Maybe TeamUserSearchSortOrder } + +userIdToDocId :: UserId -> DocId +userIdToDocId uid = DocId (idToText uid) diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs index d8b3b702554..831fa8890b8 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs @@ -2,29 +2,7 @@ module Wire.UserSearchSubsystem where -import Data.Domain -import Data.Id -import Data.Qualified -import Data.Range -import Imports import Polysemy -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) -import Wire.API.Team.Feature -import Wire.API.User.Search -import Wire.UserSearch.Types - -data UserSearchSubsystem m a where - SyncUser :: UserId -> UserSearchSubsystem m () - UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSearchSubsystem m () - SearchUsers :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m (SearchResult Contact) - BrowseTeam :: - UserId -> - BrowseTeamFilters -> - Maybe (Range 1 500 Int) -> - Maybe PagingState -> - UserSearchSubsystem m (SearchResult TeamContact) - -makeSem ''UserSearchSubsystem -- | Bulk operations, must not be used from any web handler data UserSearchSubsystemBulk m a where diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index a5b5ea8211b..8f5354a24a9 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -1,17 +1,10 @@ -{-# LANGUAGE RecordWildCards #-} - module Wire.UserSearchSubsystem.Interpreter where import Cassandra.Exec (paginateWithStateC) import Conduit (ConduitT, runConduit, (.|)) -import Control.Error (MaybeT (..)) import Data.Conduit.Combinators qualified as Conduit -import Data.Domain -import Data.Handle qualified as Handle import Data.Id import Data.Map qualified as Map -import Data.Qualified -import Data.Range import Data.Set qualified as Set import Database.Bloodhound qualified as ES import Imports @@ -19,64 +12,17 @@ import Polysemy import Polysemy.Error import Polysemy.TinyLog import Polysemy.TinyLog qualified as Log -import Servant.Client.Core (RunClient) import System.Logger.Message qualified as Log -import Wire.API.Federation.API -import Wire.API.Federation.API.Brig qualified as FedBrig -import Wire.API.Federation.Error -import Wire.API.Routes.FederationDomainConfig -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) import Wire.API.Team.Feature -import Wire.API.Team.Member -import Wire.API.Team.Permission qualified as Permission -import Wire.API.Team.SearchVisibility -import Wire.API.User -import Wire.API.User.Search -import Wire.FederationAPIAccess -import Wire.FederationConfigStore import Wire.GalleyAPIAccess -import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.IndexedUserStore (IndexedUserMigrationStore, IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) -import Wire.Sem.Metrics (Metrics) -import Wire.Sem.Metrics qualified as Metrics -import Wire.StoredUser -import Wire.UserSearch.Metrics import Wire.UserSearch.Migration import Wire.UserSearch.Types import Wire.UserSearchSubsystem import Wire.UserStore -import Wire.UserStore qualified as UserStore import Wire.UserStore.IndexUser -import Wire.UserSubsystem.Error -import Wire.UserSubsystem.Interpreter - -interpretUserSearchSubsystem :: - ( Member UserStore r, - Member GalleyAPIAccess r, - Member IndexedUserStore r, - Member Metrics r, - Member (Error UserSubsystemError) r, - Member FederationConfigStore r, - RunClient (fedM 'Brig), - Member (FederationAPIAccess fedM) r, - FederationMonad fedM, - Typeable fedM, - Member TinyLog r, - Member (Error FederationError) r - ) => - UserSubsystemConfig -> - InterpreterFor UserSearchSubsystem r -interpretUserSearchSubsystem config = interpret \case - SyncUser uid -> - syncUserImpl uid - UpdateTeamSearchVisibilityInbound status -> - updateTeamSearchVisibilityInboundImpl status - SearchUsers luid query mDomain mMaxResults -> - searchUsersImpl config luid query mDomain mMaxResults - BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> - browseTeamImpl uid browseTeamFilters mMaxResults mPagingState interpretUserSearchSubsystemBulk :: ( Member TinyLog r, @@ -93,36 +39,6 @@ interpretUserSearchSubsystemBulk = interpret \case ForceSyncAllUsers -> forceSyncAllUsersImpl MigrateData -> migrateDataImpl -syncUserImpl :: - forall r. - ( Member UserStore r, - Member GalleyAPIAccess r, - Member IndexedUserStore r, - Member Metrics r - ) => - UserId -> - Sem r () -syncUserImpl uid = - getIndexUser uid - >>= maybe delete upsert - where - delete :: Sem r () - delete = do - Metrics.incCounter indexDeleteCounter - IndexedUserStore.upsert (docId uid) (emptyUserDoc uid) ES.NoVersionControl - - upsert :: IndexUser -> Sem r () - upsert indexUser = do - vis <- - maybe - (pure defaultSearchVisibilityInbound) - teamSearchVisibilityInbound - indexUser.teamId - let userDoc = indexUserToDoc vis indexUser - version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserToVersion indexUser - Metrics.incCounter indexUpdateCounter - IndexedUserStore.upsert (docId uid) userDoc version - syncAllUsersImpl :: forall r. ( Member UserStore r, @@ -175,189 +91,7 @@ syncAllUsersWithVersion mkVersion = let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ flip Map.lookup visMap =<< indexUser.teamId mkUserDoc indexUser = indexUserToDoc (vis indexUser) indexUser mkDocVersion = mkVersion . ES.ExternalDocVersion . docVersion . indexUserToVersion - pure $ map (\u -> (docId u.userId, mkUserDoc u, mkDocVersion u)) page - -updateTeamSearchVisibilityInboundImpl :: (Member IndexedUserStore r) => TeamStatus SearchVisibilityInboundConfig -> Sem r () -updateTeamSearchVisibilityInboundImpl teamStatus = - IndexedUserStore.updateTeamSearchVisibilityInbound teamStatus.team $ - searchVisibilityInboundFromFeatureStatus teamStatus.status - -searchUsersImpl :: - forall r fedM. - ( Member UserStore r, - Member GalleyAPIAccess r, - Member (Error UserSubsystemError) r, - Member IndexedUserStore r, - Member FederationConfigStore r, - RunClient (fedM 'Brig), - Member (FederationAPIAccess fedM) r, - FederationMonad fedM, - Typeable fedM, - Member TinyLog r, - Member (Error FederationError) r - ) => - UserSubsystemConfig -> - Local UserId -> - Text -> - Maybe Domain -> - Maybe (Range 1 500 Int32) -> - Sem r (SearchResult Contact) -searchUsersImpl config searcherId searchTerm maybeDomain maybeMaxResults = do - storedSearcher <- fromMaybe (error "TODO: searcher is not real") <$> UserStore.getUser (tUnqualified searcherId) - for_ storedSearcher.teamId $ \tid -> ensurePermissions (tUnqualified searcherId) tid [SearchContacts] - let localDomain = tDomain searcherId - let queryDomain = fromMaybe localDomain maybeDomain - if queryDomain == localDomain - then searchLocally config (qualifyAs searcherId storedSearcher) searchTerm maybeMaxResults - else searchRemotely queryDomain storedSearcher.teamId searchTerm - -searchLocally :: - forall r. - ( Member GalleyAPIAccess r, - Member UserStore r, - Member IndexedUserStore r - ) => - UserSubsystemConfig -> - Local StoredUser -> - Text -> - Maybe (Range 1 500 Int32) -> - Sem r (SearchResult Contact) -searchLocally config searcher searchTerm maybeMaxResults = do - let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults - let searcherTeamId = (tUnqualified searcher).teamId - searcherId = (tUnqualified searcher).id - teamSearchInfo <- mkTeamSearchInfo searcherTeamId - - maybeExactHandleMatch <- exactHandleSearch teamSearchInfo - - let exactHandleMatchCount = length maybeExactHandleMatch - esMaxResults = maxResults - exactHandleMatchCount - - esResult <- - if esMaxResults > 0 - then IndexedUserStore.searchUsers searcherId searcherTeamId teamSearchInfo searchTerm esMaxResults - else pure $ SearchResult 0 0 0 [] FullSearch Nothing Nothing - - -- Prepend results matching exact handle and results from ES. - pure $ - esResult - { searchResults = maybeToList maybeExactHandleMatch <> map userDocToContact (searchResults esResult), - searchFound = exactHandleMatchCount + searchFound esResult, - searchReturned = exactHandleMatchCount + searchReturned esResult - } - where - handleTeamVisibility :: TeamId -> TeamSearchVisibility -> TeamSearchInfo - handleTeamVisibility _ SearchVisibilityStandard = AllUsers - handleTeamVisibility t SearchVisibilityNoNameOutsideTeam = TeamOnly t - - userDocToContact :: UserDoc -> Contact - userDocToContact userDoc = - Contact - { contactQualifiedId = tUntagged $ qualifyAs searcher userDoc.udId, - contactName = maybe "" fromName userDoc.udName, - contactColorId = fromIntegral . fromColourId <$> userDoc.udColourId, - contactHandle = Handle.fromHandle <$> userDoc.udHandle, - contactTeam = userDoc.udTeam - } - - mkTeamSearchInfo :: Maybe TeamId -> Sem r TeamSearchInfo - mkTeamSearchInfo searcherTeamId = do - case searcherTeamId of - Nothing -> pure NoTeam - Just t -> - -- This flag in brig overrules any flag on galley - it is system wide - if config.searchSameTeamOnly - then pure (TeamOnly t) - else do - -- For team users, we need to check the visibility flag - handleTeamVisibility t <$> GalleyAPIAccess.getTeamSearchVisibility t - - exactHandleSearch :: TeamSearchInfo -> Sem r (Maybe Contact) - exactHandleSearch _teamSerachInfo = runMaybeT $ do - handle <- MaybeT . pure $ Handle.parseHandle searchTerm - owner <- MaybeT $ UserStore.lookupHandle handle - storedUser <- MaybeT $ UserStore.getUser owner - let contact = contactFromStoredUser (tDomain searcher) storedUser - isContactVisible = - (config.searchSameTeamOnly && (tUnqualified searcher).teamId == storedUser.teamId) - || (not config.searchSameTeamOnly) - -- case teamSerachInfo of - -- AllUsers -> True - -- NoTeam -> isNothing (storedUser.teamId) - -- TeamOnly tid -> storedUser.teamId == Just tid - if isContactVisible - then pure contact - else MaybeT $ pure Nothing - - contactFromStoredUser :: Domain -> StoredUser -> Contact - contactFromStoredUser domain storedUser = - Contact - { contactQualifiedId = Qualified storedUser.id domain, - contactName = fromName storedUser.name, - contactHandle = Handle.fromHandle <$> storedUser.handle, - contactColorId = Just . fromIntegral . fromColourId $ storedUser.accentId, - contactTeam = storedUser.teamId - } - -searchRemotely :: - ( Member FederationConfigStore r, - RunClient (fedM 'Brig), - Member (FederationAPIAccess fedM) r, - FederationMonad fedM, - Typeable fedM, - Member TinyLog r, - Member (Error FederationError) r - ) => - Domain -> - Maybe TeamId -> - Text -> - Sem r (SearchResult Contact) -searchRemotely domain mTid searchTerm = do - Log.info $ - Log.msg (Log.val "searchRemotely") - . Log.field "domain" (show domain) - . Log.field "searchTerm" searchTerm - mFedCnf <- getFederationConfig domain - let onlyInTeams = case restriction <$> mFedCnf of - Just FederationRestrictionAllowAll -> Nothing - Just (FederationRestrictionByTeam teams) -> Just teams - -- if we are not federating at all, we also do not allow to search any remote teams - Nothing -> Just [] - - searchResponse <- - runFederated (toRemoteUnsafe domain ()) $ - fedClient @'Brig @"search-users" (FedBrig.SearchRequest searchTerm mTid onlyInTeams) - let contacts = searchResponse.contacts - let count = length contacts - pure - SearchResult - { searchResults = contacts, - searchFound = count, - searchReturned = count, - searchTook = 0, - searchPolicy = searchResponse.searchPolicy, - searchPagingState = Nothing, - searchHasMore = Nothing - } - -browseTeamImpl :: - ( Member GalleyAPIAccess r, - Member (Error UserSubsystemError) r, - Member IndexedUserStore r - ) => - UserId -> - BrowseTeamFilters -> - Maybe (Range 1 500 Int) -> - Maybe PagingState -> - Sem r (SearchResult TeamContact) -browseTeamImpl uid filters mMaxResults mPagingState = do - -- limit this to team admins to reduce risk of involuntary DOS attacks. (also, - -- this way we don't need to worry about revealing confidential user data to - -- other team members.) - ensurePermissions uid filters.teamId [Permission.AddTeamMember] - - let maxResults = maybe 15 fromRange mMaxResults - userDocToTeamContact <$$> IndexedUserStore.paginateTeamMembers filters maxResults mPagingState + pure $ map (\u -> (userIdToDocId u.userId, mkUserDoc u, mkDocVersion u)) page migrateDataImpl :: ( Member IndexedUserStore r, @@ -392,28 +126,8 @@ migrateDataImpl = do expectedMigrationVersion :: MigrationVersion expectedMigrationVersion = MigrationVersion 6 -docId :: UserId -> ES.DocId -docId uid = ES.DocId (idToText uid) - +-- TODO: This is duplicated in UserSubsystem.Interpreter teamSearchVisibilityInbound :: (Member GalleyAPIAccess r) => TeamId -> Sem r SearchVisibilityInbound teamSearchVisibilityInbound tid = searchVisibilityInboundFromFeatureStatus . (.status) <$> getFeatureConfigForTeam @_ @SearchVisibilityInboundConfig tid - -ensurePermissions :: - ( IsPerm perm, - Member GalleyAPIAccess r, - Member (Error UserSubsystemError) r - ) => - UserId -> - TeamId -> - [perm] -> - Sem r () -ensurePermissions u t perms = do - m <- GalleyAPIAccess.getTeamMember u t - unless (check m) $ - throw UserSubsystemInsufficientTeamPermissions - where - check :: Maybe TeamMember -> Bool - check (Just m) = all (hasPermission m) perms - check Nothing = False diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index a6da88cc69e..707e22d5724 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -3,15 +3,21 @@ module Wire.UserSubsystem where import Data.Default +import Data.Domain import Data.Handle (Handle) import Data.Id import Data.Qualified +import Data.Range import Imports import Polysemy import Wire.API.Federation.Error +import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) +import Wire.API.Team.Feature import Wire.API.User +import Wire.API.User.Search import Wire.Arbitrary import Wire.UserKeyStore +import Wire.UserSearch.Types -- | Who is performing this update operation? (Single source of truth: users managed by SCIM -- can't be updated by clients and vice versa.) @@ -80,6 +86,17 @@ data UserSubsystem m a where BlockListDelete :: EmailAddress -> UserSubsystem m () -- | adds an email to the block list BlockListInsert :: EmailAddress -> UserSubsystem m () + UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSubsystem m () + SearchUsers :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSubsystem m (SearchResult Contact) + BrowseTeam :: + UserId -> + BrowseTeamFilters -> + Maybe (Range 1 500 Int) -> + Maybe PagingState -> + UserSubsystem m (SearchResult TeamContact) + -- | This function exists to support migration in this susbystem, after the + -- migration this would just be an internal detail of the subsystem + InternalUpdateSearchIndex :: UserId -> UserSubsystem m () -- | the return type of 'CheckHandle' data CheckHandleResp diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 5da14f2f4ae..78655310574 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} module Wire.UserSubsystem.Interpreter ( runUserSubsystem, @@ -8,36 +9,58 @@ where import Control.Lens (view) import Control.Monad.Trans.Maybe +import Data.Domain +import Data.Either.Extra import Data.Handle (Handle) import Data.Handle qualified as Handle import Data.Id import Data.Json.Util import Data.LegalHold import Data.Qualified +import Data.Range import Data.Time.Clock -import Imports hiding (local) +import Database.Bloodhound qualified as ES +import Imports import Polysemy -import Polysemy.Error hiding (try) +import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog +import Polysemy.TinyLog qualified as Log import Servant.Client.Core +import System.Logger.Message qualified as Log import Wire.API.Federation.API +import Wire.API.Federation.API.Brig qualified as FedBrig import Wire.API.Federation.Error +import Wire.API.Routes.FederationDomainConfig +import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) import Wire.API.Team.Feature -import Wire.API.Team.Member hiding (userId) +import Wire.API.Team.Member +import Wire.API.Team.Permission qualified as Permission +import Wire.API.Team.SearchVisibility import Wire.API.User +import Wire.API.User.Search import Wire.API.UserEvent import Wire.Arbitrary import Wire.BlockListStore as BlockList import Wire.DeleteQueue import Wire.Events import Wire.FederationAPIAccess +import Wire.FederationConfigStore import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.IndexedUserStore (IndexedUserStore) +import Wire.IndexedUserStore qualified as IndexedUserStore import Wire.Sem.Concurrency +import Wire.Sem.Metrics +import Wire.Sem.Metrics qualified as Metrics import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.StoredUser import Wire.UserKeyStore +import Wire.UserSearch.Metrics +import Wire.UserSearch.Types import Wire.UserStore as UserStore +import Wire.UserStore.IndexUser import Wire.UserSubsystem import Wire.UserSubsystem.Error import Wire.UserSubsystem.HandleBlacklist @@ -64,7 +87,11 @@ runUserSubsystem :: Member Now r, RunClient (fedM 'Brig), FederationMonad fedM, - Typeable fedM + Typeable fedM, + Member TinyLog r, + Member IndexedUserStore r, + Member FederationConfigStore r, + Member Metrics r ) => UserSubsystemConfig -> InterpreterFor UserSubsystem r @@ -85,7 +112,11 @@ interpretUserSubsystem :: Member Now r, RunClient (fedM 'Brig), FederationMonad fedM, - Typeable fedM + Typeable fedM, + Member IndexedUserStore r, + Member TinyLog r, + Member FederationConfigStore r, + Member Metrics r ) => InterpreterFor UserSubsystem r interpretUserSubsystem = interpret \case @@ -102,6 +133,14 @@ interpretUserSubsystem = interpret \case IsBlocked email -> isBlockedImpl email BlockListDelete email -> blockListDeleteImpl email BlockListInsert email -> blockListInsertImpl email + UpdateTeamSearchVisibilityInbound status -> + updateTeamSearchVisibilityInboundImpl status + SearchUsers luid query mDomain mMaxResults -> + searchUsersImpl luid query mDomain mMaxResults + BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> + browseTeamImpl uid browseTeamFilters mMaxResults mPagingState + InternalUpdateSearchIndex uid -> + syncUserIndex uid isBlockedImpl :: (Member BlockListStore r) => EmailAddress -> Sem r Bool isBlockedImpl = BlockList.exists . mkEmailKey @@ -329,10 +368,10 @@ getUserProfilesWithErrorsImpl self others = do (outp -> inp -> outp) aggregate acc [] = acc aggregate (accL, accR) (Right prof : buckets) = aggregate (accL, prof <> accR) buckets - aggregate (accL, accR) (Left err : buckets) = aggregate (renderBucketError err <> accL, accR) buckets + aggregate (accL, accR) (Left e : buckets) = aggregate (renderBucketError e <> accL, accR) buckets renderBucketError :: (FederationError, Qualified [UserId]) -> [(Qualified UserId, FederationError)] - renderBucketError (err, qlist) = (,err) . (flip Qualified (qDomain qlist)) <$> qUnqualified qlist + renderBucketError (e, qlist) = (,e) . (flip Qualified (qDomain qlist)) <$> qUnqualified qlist -- | Some fields cannot be overwritten by clients for scim-managed users; some others if e2eid -- is used. If a client attempts to overwrite any of these, throw `UserSubsystem*ManagedByScim`. @@ -374,7 +413,9 @@ updateUserProfileImpl :: ( Member UserStore r, Member (Error UserSubsystemError) r, Member Events r, - Member GalleyAPIAccess r + Member GalleyAPIAccess r, + Member IndexedUserStore r, + Member Metrics r ) => Local UserId -> Maybe ConnId -> @@ -386,6 +427,8 @@ updateUserProfileImpl (tUnqualified -> uid) mconn updateOrigin update = do guardLockedFields user updateOrigin update mapError (\StoredUserUpdateHandleExists -> UserSubsystemHandleExists) $ updateUser uid (storedUserUpdate update) + let interestingToUpdateIndex = isJust update.name || isJust update.accentId + when interestingToUpdateIndex $ syncUserIndex uid generateUserEvent uid mconn (mkProfileUpdateEvent uid update) storedUserUpdate :: UserProfileUpdate -> StoredUserUpdate @@ -437,7 +480,9 @@ updateHandleImpl :: ( Member (Error UserSubsystemError) r, Member GalleyAPIAccess r, Member Events r, - Member UserStore r + Member UserStore r, + Member IndexedUserStore r, + Member Metrics r ) => Local UserId -> Maybe ConnId -> @@ -454,6 +499,7 @@ updateHandleImpl (tUnqualified -> uid) mconn updateOrigin uhandle = do throw UserSubsystemNoIdentity mapError (\StoredUserUpdateHandleExists -> UserSubsystemHandleExists) $ UserStore.updateUserHandle uid (MkStoredUserHandleUpdate user.handle newHandle) + syncUserIndex uid generateUserEvent uid mconn (mkProfileUpdateHandleEvent uid newHandle) checkHandleImpl :: (Member (Error UserSubsystemError) r, Member UserStore r) => Text -> Sem r CheckHandleResp @@ -494,3 +540,245 @@ checkHandlesImpl check num = reverse <$> collectFree [] check num case owner of Nothing -> collectFree (h : free) hs (n - 1) Just _ -> collectFree free hs n + +------------------------------------------------------------------------------- +-- Search + +syncUserIndex :: + forall r. + ( Member UserStore r, + Member GalleyAPIAccess r, + Member IndexedUserStore r, + Member Metrics r + ) => + UserId -> + Sem r () +syncUserIndex uid = + getIndexUser uid + >>= maybe deleteFromIndex upsert + where + deleteFromIndex :: Sem r () + deleteFromIndex = do + Metrics.incCounter indexDeleteCounter + IndexedUserStore.upsert (userIdToDocId uid) (emptyUserDoc uid) ES.NoVersionControl + + upsert :: IndexUser -> Sem r () + upsert indexUser = do + vis <- + maybe + (pure defaultSearchVisibilityInbound) + teamSearchVisibilityInbound + indexUser.teamId + let userDoc = indexUserToDoc vis indexUser + version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserToVersion indexUser + Metrics.incCounter indexUpdateCounter + IndexedUserStore.upsert (userIdToDocId uid) userDoc version + +teamSearchVisibilityInbound :: (Member GalleyAPIAccess r) => TeamId -> Sem r SearchVisibilityInbound +teamSearchVisibilityInbound tid = + searchVisibilityInboundFromFeatureStatus . (.status) + <$> getFeatureConfigForTeam @_ @SearchVisibilityInboundConfig tid + +updateTeamSearchVisibilityInboundImpl :: (Member IndexedUserStore r) => TeamStatus SearchVisibilityInboundConfig -> Sem r () +updateTeamSearchVisibilityInboundImpl teamStatus = + IndexedUserStore.updateTeamSearchVisibilityInbound teamStatus.team $ + searchVisibilityInboundFromFeatureStatus teamStatus.status + +searchUsersImpl :: + forall r fedM. + ( Member UserStore r, + Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r, + Member IndexedUserStore r, + Member FederationConfigStore r, + RunClient (fedM 'Brig), + Member (FederationAPIAccess fedM) r, + FederationMonad fedM, + Typeable fedM, + Member TinyLog r, + Member (Error FederationError) r, + Member (Input UserSubsystemConfig) r + ) => + Local UserId -> + Text -> + Maybe Domain -> + Maybe (Range 1 500 Int32) -> + Sem r (SearchResult Contact) +searchUsersImpl searcherId searchTerm maybeDomain maybeMaxResults = do + storedSearcher <- fromMaybe (error "TODO: searcher is not real") <$> UserStore.getUser (tUnqualified searcherId) + for_ storedSearcher.teamId $ \tid -> ensurePermissions (tUnqualified searcherId) tid [SearchContacts] + let localDomain = tDomain searcherId + queryDomain = fromMaybe localDomain maybeDomain + if queryDomain == localDomain + then searchLocally (qualifyAs searcherId storedSearcher) searchTerm maybeMaxResults + else searchRemotely queryDomain storedSearcher.teamId searchTerm + +searchLocally :: + forall r. + ( Member GalleyAPIAccess r, + Member UserStore r, + Member IndexedUserStore r, + Member (Input UserSubsystemConfig) r + ) => + Local StoredUser -> + Text -> + Maybe (Range 1 500 Int32) -> + Sem r (SearchResult Contact) +searchLocally searcher searchTerm maybeMaxResults = do + let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults + let searcherTeamId = (tUnqualified searcher).teamId + searcherId = (tUnqualified searcher).id + teamSearchInfo <- mkTeamSearchInfo searcherTeamId + + maybeExactHandleMatch <- exactHandleSearch teamSearchInfo + + let exactHandleMatchCount = length maybeExactHandleMatch + esMaxResults = maxResults - exactHandleMatchCount + + esResult <- + if esMaxResults > 0 + then IndexedUserStore.searchUsers searcherId searcherTeamId teamSearchInfo searchTerm esMaxResults + else pure $ SearchResult 0 0 0 [] FullSearch Nothing Nothing + + -- Prepend results matching exact handle and results from ES. + pure $ + esResult + { searchResults = maybeToList maybeExactHandleMatch <> map userDocToContact (searchResults esResult), + searchFound = exactHandleMatchCount + searchFound esResult, + searchReturned = exactHandleMatchCount + searchReturned esResult + } + where + handleTeamVisibility :: TeamId -> TeamSearchVisibility -> TeamSearchInfo + handleTeamVisibility _ SearchVisibilityStandard = AllUsers + handleTeamVisibility t SearchVisibilityNoNameOutsideTeam = TeamOnly t + + userDocToContact :: UserDoc -> Contact + userDocToContact userDoc = + Contact + { contactQualifiedId = tUntagged $ qualifyAs searcher userDoc.udId, + contactName = maybe "" fromName userDoc.udName, + contactColorId = fromIntegral . fromColourId <$> userDoc.udColourId, + contactHandle = Handle.fromHandle <$> userDoc.udHandle, + contactTeam = userDoc.udTeam + } + + mkTeamSearchInfo :: Maybe TeamId -> Sem r TeamSearchInfo + mkTeamSearchInfo searcherTeamId = do + config <- input + case searcherTeamId of + Nothing -> pure NoTeam + Just t -> + -- This flag in brig overrules any flag on galley - it is system wide + if config.searchSameTeamOnly + then pure (TeamOnly t) + else do + -- For team users, we need to check the visibility flag + handleTeamVisibility t <$> GalleyAPIAccess.getTeamSearchVisibility t + + exactHandleSearch :: TeamSearchInfo -> Sem r (Maybe Contact) + exactHandleSearch _teamSerachInfo = runMaybeT $ do + handle <- MaybeT . pure $ Handle.parseHandle searchTerm + owner <- MaybeT $ UserStore.lookupHandle handle + storedUser <- MaybeT $ UserStore.getUser owner + config <- lift input + let contact = contactFromStoredUser (tDomain searcher) storedUser + isContactVisible = + (config.searchSameTeamOnly && (tUnqualified searcher).teamId == storedUser.teamId) + || (not config.searchSameTeamOnly) + -- case teamSerachInfo of + -- AllUsers -> True + -- NoTeam -> isNothing (storedUser.teamId) + -- TeamOnly tid -> storedUser.teamId == Just tid + if isContactVisible + then pure contact + else MaybeT $ pure Nothing + + contactFromStoredUser :: Domain -> StoredUser -> Contact + contactFromStoredUser domain storedUser = + Contact + { contactQualifiedId = Qualified storedUser.id domain, + contactName = fromName storedUser.name, + contactHandle = Handle.fromHandle <$> storedUser.handle, + contactColorId = Just . fromIntegral . fromColourId $ storedUser.accentId, + contactTeam = storedUser.teamId + } + +searchRemotely :: + ( Member FederationConfigStore r, + RunClient (fedM 'Brig), + Member (FederationAPIAccess fedM) r, + FederationMonad fedM, + Typeable fedM, + Member TinyLog r, + Member (Error FederationError) r + ) => + Domain -> + Maybe TeamId -> + Text -> + Sem r (SearchResult Contact) +searchRemotely domain mTid searchTerm = do + Log.info $ + Log.msg (Log.val "searchRemotely") + . Log.field "domain" (show domain) + . Log.field "searchTerm" searchTerm + mFedCnf <- getFederationConfig domain + let onlyInTeams = case restriction <$> mFedCnf of + Just FederationRestrictionAllowAll -> Nothing + Just (FederationRestrictionByTeam teams) -> Just teams + -- if we are not federating at all, we also do not allow to search any remote teams + Nothing -> Just [] + + searchResponse <- + runFederated (toRemoteUnsafe domain ()) $ + fedClient @'Brig @"search-users" (FedBrig.SearchRequest searchTerm mTid onlyInTeams) + let contacts = searchResponse.contacts + let count = length contacts + pure + SearchResult + { searchResults = contacts, + searchFound = count, + searchReturned = count, + searchTook = 0, + searchPolicy = searchResponse.searchPolicy, + searchPagingState = Nothing, + searchHasMore = Nothing + } + +browseTeamImpl :: + ( Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r, + Member IndexedUserStore r + ) => + UserId -> + BrowseTeamFilters -> + Maybe (Range 1 500 Int) -> + Maybe PagingState -> + Sem r (SearchResult TeamContact) +browseTeamImpl uid filters mMaxResults mPagingState = do + -- limit this to team admins to reduce risk of involuntary DOS attacks. (also, + -- this way we don't need to worry about revealing confidential user data to + -- other team members.) + ensurePermissions uid filters.teamId [Permission.AddTeamMember] + + let maxResults = maybe 15 fromRange mMaxResults + userDocToTeamContact <$$> IndexedUserStore.paginateTeamMembers filters maxResults mPagingState + +-- TODO: Move this somewhere more appropriate as this function is broader than +-- just the UserSubsystem +ensurePermissions :: + ( IsPerm perm, + Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r + ) => + UserId -> + TeamId -> + [perm] -> + Sem r () +ensurePermissions u t perms = do + m <- GalleyAPIAccess.getTeamMember u t + unless (check m) $ + throw UserSubsystemInsufficientTeamPermissions + where + check :: Maybe TeamMember -> Bool + check (Just m) = all (hasPermission m) perms + check Nothing = False From 459c6b85b41d3f70a8b78531dd1579f724149e97 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 26 Aug 2024 16:54:44 +0200 Subject: [PATCH 19/48] Wire.BlockListStore.Cassandra: Take ClientState as an arg instead of putting MonadClient constraint --- .../src/Wire/BlockListStore/Cassandra.hs | 12 ++++++------ services/brig/src/Brig/CanonicalInterpreter.hs | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs index d8e0e0f077a..f00431d8201 100644 --- a/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/BlockListStore/Cassandra.hs @@ -10,13 +10,13 @@ import Wire.BlockListStore (BlockListStore (..)) import Wire.UserKeyStore interpretBlockListStoreToCassandra :: - forall m r a. - (MonadClient m, Member (Embed m) r) => - Sem (BlockListStore ': r) a -> - Sem r a -interpretBlockListStoreToCassandra = + forall r. + (Member (Embed IO) r) => + ClientState -> + InterpreterFor BlockListStore r +interpretBlockListStoreToCassandra casClient = interpret $ - embed @m . \case + embed @IO . runClient casClient . \case Insert uk -> insert uk Exists uk -> exists uk Delete uk -> delete uk diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 7b4f1417472..1e00ed82c76 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -209,7 +209,7 @@ runBrigToIO e (AppT ma) = do . runDelay . nowToIOAction (e ^. currentTime) . userPendingActivationStoreToCassandra - . interpretBlockListStoreToCassandra @Cas.Client + . interpretBlockListStoreToCassandra (e ^. casClient) . interpretJwtTools . interpretPublicKeyBundle . interpretJwk From 2560436c8c1eb79184738022f14aba7cfe7226bd Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 26 Aug 2024 17:00:31 +0200 Subject: [PATCH 20/48] brig: Untangle sending user notifs and maintaining internal state Brig.IO.Intra.onUserEvent used to keep the search index up to date, send user events and send journal events. The keeping the search index up to date part is now bubbled up to all the places which were calling this function. This commit also deals with there no longer being UserSearchSubsystem. --- services/brig/src/Brig/API/Auth.hs | 49 ++---- services/brig/src/Brig/API/Client.hs | 54 +----- services/brig/src/Brig/API/Federation.hs | 9 +- services/brig/src/Brig/API/Internal.hs | 163 ++++++------------ services/brig/src/Brig/API/Public.hs | 75 +++----- services/brig/src/Brig/API/User.hs | 127 +++++--------- .../brig/src/Brig/CanonicalInterpreter.hs | 4 - services/brig/src/Brig/IO/Intra.hs | 49 +----- services/brig/src/Brig/Index/Eval.hs | 24 +-- .../brig/src/Brig/InternalEvent/Process.hs | 16 +- services/brig/src/Brig/Team/API.hs | 32 +--- services/brig/src/Brig/User/Auth.hs | 59 ++----- 12 files changed, 191 insertions(+), 470 deletions(-) diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index fce4e8a6919..59b5f0b2060 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -23,7 +23,6 @@ import Brig.API.Types import Brig.API.User import Brig.App import Brig.Data.User qualified as User -import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Options import Brig.User.Auth qualified as Auth import Brig.ZAuth hiding (Env, settings) @@ -36,14 +35,12 @@ import Data.List1 (List1 (..)) import Data.Qualified import Data.Text qualified as T import Data.Text.Lazy qualified as LT -import Data.Time.Clock (UTCTime) import Data.ZAuth.Token qualified as ZAuth import Imports import Network.HTTP.Types import Network.Wai.Utilities ((!>>)) import Network.Wai.Utilities.Error qualified as Wai import Polysemy -import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Wire.API.Error import Wire.API.Error.Brig qualified as E @@ -54,24 +51,18 @@ import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso import Wire.BlockListStore import Wire.EmailSubsystem (EmailSubsystem) +import Wire.Events (Events) import Wire.GalleyAPIAccess -import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore) -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore -import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserStore import Wire.UserSubsystem import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) accessH :: ( Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Maybe ClientId -> [Either Text SomeUserToken] -> @@ -86,12 +77,8 @@ accessH mcid ut' mat' = do access :: ( TokenPair u a, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Maybe ClientId -> NonEmpty (Token u) -> @@ -109,16 +96,12 @@ sendLoginCode _ = login :: ( Member GalleyAPIAccess r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member PasswordStore r, Member UserKeyStore r, Member UserStore r, Member VerificationCodeSubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Login -> Maybe Bool -> @@ -146,7 +129,7 @@ changeSelfEmailH :: ( Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r ) => [Either Text SomeUserToken] -> Maybe (Either Text SomeAccessToken) -> @@ -180,13 +163,9 @@ removeCookies lusr (RemoveCookies pw lls ids) = legalHoldLogin :: ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => LegalHoldLogin -> Handler r SomeAccess @@ -197,12 +176,8 @@ legalHoldLogin lhl = do ssoLogin :: ( Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => SsoLogin -> Maybe Bool -> diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index e30c0441fdf..6a6f5381172 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -53,7 +53,6 @@ import Brig.App import Brig.Data.Client qualified as Data import Brig.Data.Nonce as Nonce import Brig.Data.User qualified as Data -import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.JwtTools (JwtTools) import Brig.Effects.JwtTools qualified as JwtTools import Brig.Effects.PublicKeyBundle (PublicKeyBundle) @@ -83,13 +82,10 @@ import Data.Qualified import Data.Set qualified as Set import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error -import Data.Time.Clock (UTCTime) import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities import Polysemy -import Polysemy.Input (Input) -import Polysemy.TinyLog import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log @@ -108,14 +104,14 @@ import Wire.API.UserEvent import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) import Wire.DeleteQueue import Wire.EmailSubsystem (EmailSubsystem, sendNewClientEmail) +import Wire.Events (Events) +import Wire.Events qualified as Events import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) import Wire.Sem.Now as Now -import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) @@ -163,16 +159,11 @@ lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk addClient :: ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member TinyLog r, Member DeleteQueue r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member UserSearchSubsystem r + Member Events r ) => UserId -> Maybe ConnId -> @@ -185,16 +176,11 @@ addClient = addClientWithReAuthPolicy Data.reAuthForNewClients addClientWithReAuthPolicy :: forall r. ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, Member DeleteQueue r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member UserSearchSubsystem r + Member Events r ) => Data.ReAuthPolicy -> UserId -> @@ -223,7 +209,7 @@ addClientWithReAuthPolicy policy u con new = do for_ old $ execDelete u con liftSem $ GalleyAPIAccess.newClient u (clientId clt) liftSem $ Intra.onClientEvent u con (ClientAdded clt) - when (clientType clt == LegalHoldClientType) $ liftSem $ Intra.onUserEvent u con (UserLegalHoldEnabled u) + when (clientType clt == LegalHoldClientType) $ liftSem $ Events.generateUserEvent u con (UserLegalHoldEnabled u) when (count > 1) $ for_ (userEmail usr) $ \email -> @@ -516,20 +502,9 @@ pubClient c = pubClientClass = clientClass c } -legalHoldClientRequested :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r - ) => - UserId -> - LegalHoldClientRequest -> - AppT r () +legalHoldClientRequested :: (Member Events r) => UserId -> LegalHoldClientRequest -> AppT r () legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = - liftSem $ Intra.onUserEvent targetUser Nothing lhClientEvent + liftSem $ Events.generateUserEvent targetUser Nothing lhClientEvent where clientId :: ClientId clientId = clientIdFromPrekey $ unpackLastPrekey lastPrekey' @@ -538,25 +513,14 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke lhClientEvent :: UserEvent lhClientEvent = LegalHoldClientRequested eventData -removeLegalHoldClient :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member DeleteQueue r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r - ) => - UserId -> - AppT r () +removeLegalHoldClient :: (Member DeleteQueue r, Member Events r) => UserId -> AppT r () removeLegalHoldClient uid = do clients <- wrapClient $ Data.lookupClients uid -- Should only be one; but just in case we'll treat it as a list let legalHoldClients = filter ((== LegalHoldClientType) . clientType) clients -- maybe log if this isn't the case forM_ legalHoldClients (execDelete uid Nothing) - liftSem $ Intra.onUserEvent uid Nothing (UserLegalHoldDisabled uid) + liftSem $ Events.generateUserEvent uid Nothing (UserLegalHoldDisabled uid) createAccessToken :: (Member JwtTools r, Member Now r, Member PublicKeyBundle r) => diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index f959faa2c2d..162e2e848e3 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -76,7 +76,8 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.UserStore -import Wire.UserSubsystem +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as UserSubsystem type FederationAPI = "federation" :> BrigApi @@ -167,7 +168,7 @@ getUserByHandle domain handle = do pure Nothing Just ownerId -> do localOwnerId <- qualifyLocal ownerId - liftSem $ getLocalUserProfile localOwnerId + liftSem $ UserSubsystem.getLocalUserProfile localOwnerId getUsersByIds :: (Member UserSubsystem r) => @@ -176,7 +177,7 @@ getUsersByIds :: ExceptT HttpError (AppT r) [UserProfile] getUsersByIds _ uids = do luids <- qualifyLocal uids - lift $ liftSem $ getLocalUserProfiles luids + lift $ liftSem $ UserSubsystem.getLocalUserProfiles luids claimPrekey :: (Member DeleteQueue r) => Domain -> (UserId, ClientId) -> (Handler r) (Maybe ClientPrekey) claimPrekey _ (user, client) = do @@ -252,7 +253,7 @@ searchUsers domain (SearchRequest searchTerm mTeam mOnlyInTeams) = do mFoundUserTeamId <- lift $ wrapClient $ Data.lookupUserTeam foundUser localFoundUser <- qualifyLocal foundUser if isTeamAllowed mOnlyInTeams mFoundUserTeamId - then lift $ liftSem $ (fmap contactFromProfile . maybeToList) <$> getLocalUserProfile localFoundUser + then lift $ liftSem $ (fmap contactFromProfile . maybeToList) <$> UserSubsystem.getLocalUserProfile localFoundUser else pure [] | otherwise = pure [] diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index c43ee03d060..1dedb2c312e 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -37,9 +37,7 @@ import Brig.Data.Client qualified as Data import Brig.Data.Connection qualified as Data import Brig.Data.MLS.KeyPackage qualified as Data import Brig.Data.User qualified as Data -import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) -import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) import Brig.Provider.API qualified as Provider import Brig.Team.API qualified as Team @@ -63,12 +61,10 @@ import Data.Map.Strict qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Text qualified as T -import Data.Time.Clock (UTCTime) import Data.Time.Clock.System import Imports hiding (head) import Network.Wai.Utilities as Utilities import Polysemy -import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.OpenApi.Internal.Orphans () @@ -95,6 +91,8 @@ import Wire.BlockListStore (BlockListStore) import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem (EmailSubsystem) +import Wire.Events (Events) +import Wire.Events qualified as Events import Wire.FederationConfigStore ( AddFederationRemoteResult (..), AddFederationRemoteTeamResult (..), @@ -107,9 +105,7 @@ import Wire.NotificationSubsystem import Wire.PropertySubsystem import Wire.Rpc import Wire.Sem.Concurrency -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore -import Wire.UserSearchSubsystem (UserSearchSubsystem, updateTeamSearchVisibilityInbound) import Wire.UserStore import Wire.UserSubsystem import Wire.UserSubsystem qualified as UserSubsystem @@ -122,13 +118,10 @@ servantSitemap :: ( Member BlockListStore r, Member DeleteQueue r, Member (Concurrency 'Unsafe) r, - Member (ConnectionStore InternalPaging) r, Member (Embed HttpClientIO) r, Member FederationConfigStore r, Member AuthenticationSubsystem r, Member GalleyAPIAccess r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, Member NotificationSubsystem r, Member UserSubsystem r, Member UserStore r, @@ -140,7 +133,7 @@ servantSitemap :: Member EmailSubsystem r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member Events r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -186,13 +179,10 @@ accountAPI :: Member UserKeyStore r, Member UserStore r, Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member Events r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -236,16 +226,12 @@ teamsAPI :: Member (UserPendingActivationStore p) r, Member BlockListStore r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member UserKeyStore r, Member (Concurrency 'Unsafe) r, Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSending r, Member UserSubsystem r, - Member UserSearchSubsystem r + Member Events r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = @@ -269,13 +255,9 @@ clientAPI = Named @"update-client-last-active" updateClientLastActive authAPI :: ( Member GalleyAPIAccess r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => ServerT BrigIRoutes.AuthAPI (Handler r) authAPI = @@ -402,16 +384,11 @@ internalSearchIndexAPI = -- | Add a client without authentication checks addClientInternalH :: ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member DeleteQueue r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member UserSearchSubsystem r + Member Events r ) => UserId -> Maybe Bool -> @@ -424,33 +401,11 @@ addClientInternalH usr mSkipReAuth new connId = do | otherwise = Data.reAuthForNewClients API.addClientWithReAuthPolicy policy usr connId new !>> clientError -legalHoldClientRequestedH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r - ) => - UserId -> - LegalHoldClientRequest -> - (Handler r) NoContent +legalHoldClientRequestedH :: (Member Events r) => UserId -> LegalHoldClientRequest -> (Handler r) NoContent legalHoldClientRequestedH targetUser clientRequest = do lift $ NoContent <$ API.legalHoldClientRequested targetUser clientRequest -removeLegalHoldClientH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member DeleteQueue r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r - ) => - UserId -> - (Handler r) NoContent +removeLegalHoldClientH :: (Member DeleteQueue r, Member Events r) => UserId -> (Handler r) NoContent removeLegalHoldClientH uid = do lift $ NoContent <$ API.removeLegalHoldClient uid @@ -468,13 +423,9 @@ createUserNoVerify :: Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member UserKeyStore r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => NewUser -> (Handler r) (Either RegisterError SelfProfile) @@ -492,14 +443,9 @@ createUserNoVerify uData = lift . runExceptT $ do createUserNoVerifySpar :: ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member UserSubsystem r, Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) @@ -522,11 +468,9 @@ deleteUserNoAuthH :: Member UserStore r, Member TinyLog r, Member UserKeyStore r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => UserId -> (Handler r) DeleteUserResponse @@ -537,14 +481,33 @@ deleteUserNoAuthH uid = do AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted AccountDeleted -> pure UserResponseAccountDeleted -changeSelfEmailMaybeSendH :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, Member UserSearchSubsystem r) => UserId -> EmailUpdate -> Maybe Bool -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSendH :: + ( Member BlockListStore r, + Member UserKeyStore r, + Member EmailSubsystem r, + Member UserSubsystem r + ) => + UserId -> + EmailUpdate -> + Maybe Bool -> + (Handler r) ChangeEmailResponse changeSelfEmailMaybeSendH u body (fromMaybe False -> validate) = do let email = euEmail body changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email UpdateOriginScim data MaybeSendEmail = ActuallySendEmail | DoNotSendEmail -changeSelfEmailMaybeSend :: (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, Member UserSearchSubsystem r) => UserId -> MaybeSendEmail -> EmailAddress -> UpdateOriginType -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSend :: + ( Member BlockListStore r, + Member UserKeyStore r, + Member EmailSubsystem r, + Member UserSubsystem r + ) => + UserId -> + MaybeSendEmail -> + EmailAddress -> + UpdateOriginType -> + (Handler r) ChangeEmailResponse changeSelfEmailMaybeSend u ActuallySendEmail email allowScim = do API.changeSelfEmail u email allowScim changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do @@ -637,13 +600,8 @@ getPasswordResetCode email = >>= maybe (throwStd (errorToWai @'E.InvalidPasswordResetKey)) pure changeAccountStatusH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + ( Member UserSubsystem r, + Member Events r ) => UserId -> AccountStatusUpdate -> @@ -715,41 +673,34 @@ addBlacklist :: (Member BlockListStore r) => EmailAddress -> Handler r NoContent addBlacklist email = lift $ NoContent <$ API.blacklistInsert email updateSSOIdH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + ( Member UserSubsystem r, + Member Events r ) => UserId -> UserSSOId -> (Handler r) UpdateSSOIdResponse -updateSSOIdH uid ssoid = do - success <- lift $ wrapClient $ Data.updateSSOId uid (Just ssoid) - if success - then do - lift $ liftSem $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid})) - pure UpdateSSOIdSuccess - else pure UpdateSSOIdNotFound +updateSSOIdH uid ssoid = lift $ do + success <- wrapClient $ Data.updateSSOId uid (Just ssoid) + liftSem $ + if success + then do + UserSubsystem.internalUpdateSearchIndex uid + Events.generateUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid})) + pure UpdateSSOIdSuccess + else pure UpdateSSOIdNotFound deleteSSOIdH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + ( Member UserSubsystem r, + Member Events r ) => UserId -> (Handler r) UpdateSSOIdResponse -deleteSSOIdH uid = do - success <- lift $ wrapClient $ Data.updateSSOId uid Nothing +deleteSSOIdH uid = lift $ do + success <- wrapClient $ Data.updateSSOId uid Nothing if success - then do - lift $ liftSem $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True})) + then liftSem $ do + UserSubsystem.internalUpdateSearchIndex uid + Events.generateUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True})) pure UpdateSSOIdSuccess else pure UpdateSSOIdNotFound diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index ea45957bb5e..0cedf09a414 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -41,7 +41,6 @@ import Brig.Calling.API qualified as Calling import Brig.Data.Connection qualified as Data import Brig.Data.Nonce as Nonce import Brig.Data.User qualified as Data -import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.JwtTools (JwtTools) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) import Brig.Effects.SFT @@ -82,14 +81,12 @@ import Data.Qualified import Data.Range import Data.Schema () import Data.Text.Encoding qualified as Text -import Data.Time.Clock (UTCTime) import Data.ZAuth.Token qualified as ZAuth import FileEmbedLzma import Imports hiding (head) import Network.Socket (PortNumber) import Network.Wai.Utilities as Utilities import Polysemy -import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant qualified @@ -148,6 +145,7 @@ import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem import Wire.Error +import Wire.Events (Events) import Wire.FederationConfigStore (FederationConfigStore) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess @@ -157,11 +155,8 @@ import Wire.PropertySubsystem import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserSearch.Types -import Wire.UserSearchSubsystem (UserSearchSubsystem) -import Wire.UserSearchSubsystem qualified as UserSearchSubsystem import Wire.UserStore (UserStore) import Wire.UserSubsystem hiding (checkHandle, checkHandles) import Wire.UserSubsystem qualified as UserSubsystem @@ -264,13 +259,10 @@ servantSitemap :: ( Member BlockListStore r, Member DeleteQueue r, Member (Concurrency 'Unsafe) r, - Member (ConnectionStore InternalPaging) r, Member (Embed HttpClientIO) r, Member (Embed IO) r, Member FederationConfigStore r, - Member (Input (Local ())) r, Member AuthenticationSubsystem r, - Member (Input UTCTime) r, Member Jwk r, Member GalleyAPIAccess r, Member JwtTools r, @@ -288,7 +280,7 @@ servantSitemap :: Member EmailSending r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member Events r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -458,7 +450,7 @@ servantSitemap = -- Handlers browseTeamHandler :: - (Member UserSearchSubsystem r) => + (Member UserSubsystem r) => UserId -> TeamId -> Maybe Text -> @@ -470,7 +462,7 @@ browseTeamHandler :: Handler r (Public.SearchResult Public.TeamContact) browseTeamHandler uid tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder mMaxResults mPagingState = do let browseTeamFilters = BrowseTeamFilters tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder - lift . liftSem $ UserSearchSubsystem.browseTeam uid browseTeamFilters mMaxResults mPagingState + lift . liftSem $ UserSubsystem.browseTeam uid browseTeamFilters mMaxResults mPagingState setPropertyH :: (Member PropertySubsystem r) => UserId -> ConnId -> Public.PropertyKey -> Public.RawPropertyValue -> Handler r () setPropertyH u c key raw = lift . liftSem $ setProperty u c key raw @@ -569,16 +561,11 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do addClient :: ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, Member DeleteQueue r, Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member UserSearchSubsystem r + Member Events r ) => UserId -> ConnId -> @@ -702,15 +689,11 @@ createUser :: Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member UserKeyStore r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member EmailSending r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Public.NewUserPublic -> Handler r (Either Public.RegisterError Public.RegisterSuccess) @@ -924,15 +907,9 @@ removePhone :: UserId -> Handler r (Maybe Public.RemoveIdentityError) removePhone _ = (lift . pure) Nothing removeEmail :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member UserKeyStore r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, + ( Member UserKeyStore r, Member UserSubsystem r, - Member UserSearchSubsystem r + Member Events r ) => UserId -> Handler r (Maybe Public.RemoveIdentityError) @@ -1042,14 +1019,14 @@ sendActivationCode ac = do API.sendActivationCode email (ac.locale) !>> sendActCodeError searchUsersHandler :: - (Member UserSearchSubsystem r) => + (Member UserSubsystem r) => Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> Handler r (Public.SearchResult Public.Contact) searchUsersHandler luid term mDomain mMaxResults = - lift . liftSem $ UserSearchSubsystem.searchUsers luid term mDomain mMaxResults + lift . liftSem $ UserSubsystem.searchUsers luid term mDomain mMaxResults -- | If the user presents an email address from a blocked domain, throw an error. -- @@ -1199,13 +1176,11 @@ deleteSelfUser :: Member NotificationSubsystem r, Member UserStore r, Member PasswordStore r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => UserId -> Public.DeleteUser -> @@ -1218,13 +1193,11 @@ verifyDeleteUser :: Member NotificationSubsystem r, Member UserStore r, Member TinyLog r, - Member (Input (Local ())) r, Member UserKeyStore r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Public.VerifyDeleteUser -> Handler r () @@ -1236,7 +1209,7 @@ updateUserEmail :: Member UserKeyStore r, Member GalleyAPIAccess r, Member EmailSubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r ) => UserId -> UserId -> @@ -1267,12 +1240,8 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do activate :: ( Member GalleyAPIAccess r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Public.ActivationKey -> Public.ActivationCode -> @@ -1285,12 +1254,8 @@ activate k c = do activateKey :: ( Member GalleyAPIAccess r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Public.Activate -> (Handler r) ActivationRespWithStatus diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 410f98b8cf1..c60c0766ec0 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -83,7 +83,6 @@ import Brig.Data.Connection (countConnections) import Brig.Data.Connection qualified as Data import Brig.Data.User import Brig.Data.User qualified as Data -import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra @@ -109,12 +108,11 @@ import Data.List1 as List1 (List1, singleton) import Data.Misc import Data.Qualified import Data.Range -import Data.Time.Clock (UTCTime, addUTCTime) +import Data.Time.Clock (addUTCTime) import Data.UUID.V4 (nextRandom) import Imports import Network.Wai.Utilities import Polysemy -import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import Prometheus qualified as Prom @@ -141,15 +139,14 @@ import Wire.BlockListStore as BlockListStore import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error +import Wire.Events (Events) +import Wire.Events qualified as Events import Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.PropertySubsystem as PropertySubsystem import Wire.Sem.Concurrency -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore -import Wire.UserSearchSubsystem (UserSearchSubsystem) -import Wire.UserSearchSubsystem qualified as UserSearchSubsystem import Wire.UserStore import Wire.UserSubsystem as User import Wire.UserSubsystem.HandleBlacklist @@ -193,14 +190,9 @@ verifyUniquenessAndCheckBlacklist uk = do createUserSpar :: forall r. ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, Member UserSubsystem r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member Events r ) => NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult @@ -222,7 +214,8 @@ createUserSpar new = do Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo Nothing -> pure () -- Nothing to do liftSem $ GalleyAPIAccess.createSelfConv uid - liftSem $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) + liftSem $ User.internalUpdateSearchIndex uid + liftSem $ Events.generateUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -268,12 +261,8 @@ createUser :: Member (UserPendingActivationStore p) r, Member UserKeyStore r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member Events r, + Member UserSubsystem r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -331,7 +320,7 @@ createUser new = do wrapClient $ Data.insertAccount account Nothing pw False liftSem $ GalleyAPIAccess.createSelfConv uid - liftSem $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) + liftSem $ Events.generateUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -533,7 +522,7 @@ changeSelfEmail :: ( Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r ) => UserId -> EmailAddress -> @@ -546,7 +535,7 @@ changeSelfEmail u email allowScim = do ChangeEmailNeedsActivation (usr, adata, en) -> lift $ do liftSem $ sendOutEmail usr adata en wrapClient $ Data.updateEmailUnvalidated u email - liftSem $ UserSearchSubsystem.syncUser u + liftSem $ User.internalUpdateSearchIndex u pure ChangeEmailResponseNeedsActivation where sendOutEmail usr adata en = do @@ -583,15 +572,9 @@ changeEmail u email updateOrigin = do -- Remove Email removeEmail :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member UserKeyStore r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, + ( Member UserKeyStore r, Member UserSubsystem r, - Member UserSearchSubsystem r + Member Events r ) => UserId -> ExceptT RemoveIdentityError (AppT r) () @@ -601,7 +584,9 @@ removeEmail uid = do Just (SSOIdentity (UserSSOId _) (Just e)) -> lift $ do liftSem $ deleteKey $ mkEmailKey e wrapClient $ Data.deleteEmail uid - liftSem $ Intra.onUserEvent uid Nothing (emailRemoved uid e) + -- TODO: This doesn't delete user's email address from the index, looks + -- like a bug + liftSem $ Events.generateUserEvent uid Nothing (emailRemoved uid e) Just _ -> throwE LastIdentity Nothing -> throwE NoIdentity @@ -630,13 +615,9 @@ revokeIdentity key = do changeAccountStatus :: forall r. ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member (Concurrency 'Unsafe) r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => List1 UserId -> AccountStatus -> @@ -651,16 +632,12 @@ changeAccountStatus usrs status = do Sem r () update ev u = do embed $ Data.updateStatus u status - Intra.onUserEvent u Nothing (ev u) + User.internalUpdateSearchIndex u + Events.generateUserEvent u Nothing (ev u) changeSingleAccountStatus :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + ( Member UserSubsystem r, + Member Events r ) => UserId -> AccountStatus -> @@ -670,7 +647,8 @@ changeSingleAccountStatus uid status = do ev <- mkUserEvent (List1.singleton uid) status lift $ do wrapClient $ Data.updateStatus uid status - liftSem $ Intra.onUserEvent uid Nothing (ev uid) + liftSem $ User.internalUpdateSearchIndex uid + liftSem $ Events.generateUserEvent uid Nothing (ev uid) mkUserEvent :: (Traversable t) => t UserId -> AccountStatus -> ExceptT AccountStatusError (AppT r) (UserId -> UserEvent) mkUserEvent usrs status = @@ -689,12 +667,8 @@ mkUserEvent usrs status = activate :: ( Member GalleyAPIAccess r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => ActivationTarget -> ActivationCode -> @@ -706,12 +680,8 @@ activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: ( Member GalleyAPIAccess r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => ActivationTarget -> ActivationCode -> @@ -754,12 +724,8 @@ preverify tgt code = do onActivated :: ( Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => ActivationEvent -> AppT r (UserId, Maybe UserIdentity, Bool) @@ -767,10 +733,12 @@ onActivated (AccountActivated account) = liftSem $ do let uid = userId (accountUser account) Log.debug $ field "user" (toByteString uid) . field "action" (val "User.onActivated") Log.info $ field "user" (toByteString uid) . msg (val "User activated") - Intra.onUserEvent uid Nothing $ UserActivated (accountUser account) + User.internalUpdateSearchIndex uid + Events.generateUserEvent uid Nothing $ UserActivated (accountUser account) pure (uid, userIdentity (accountUser account), True) onActivated (EmailActivated uid email) = do - liftSem $ Intra.onUserEvent uid Nothing (emailUpdated uid email) + -- TODO: Looks like a bug to not update the index + liftSem $ Events.generateUserEvent uid Nothing (emailUpdated uid email) wrapHttpClient $ Data.deleteEmailUnvalidated uid pure (uid, Just (EmailIdentity email), False) @@ -882,15 +850,13 @@ deleteSelfUser :: Member (Embed HttpClientIO) r, Member UserKeyStore r, Member NotificationSubsystem r, - Member (Input (Local ())) r, Member PasswordStore r, Member UserStore r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => UserId -> Maybe PlainTextPassword6 -> @@ -957,13 +923,11 @@ verifyDeleteUser :: Member NotificationSubsystem r, Member UserKeyStore r, Member TinyLog r, - Member (Input (Local ())) r, Member UserStore r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => VerifyDeleteUser -> ExceptT DeleteUserError (AppT r) () @@ -986,12 +950,10 @@ ensureAccountDeleted :: Member NotificationSubsystem r, Member TinyLog r, Member UserKeyStore r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member UserStore r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => UserId -> AppT r DeleteUserResult @@ -1037,12 +999,10 @@ deleteAccount :: Member NotificationSubsystem r, Member UserKeyStore r, Member TinyLog r, - Member (Input (Local ())) r, Member UserStore r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => UserAccount -> Sem r () @@ -1060,7 +1020,8 @@ deleteAccount (accountUser -> user) = do Intra.rmUser uid (userAssets user) embed $ Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) luid <- embed $ qualifyLocal uid - Intra.onUserEvent uid Nothing (UserDeleted (tUntagged luid)) + User.internalUpdateSearchIndex uid + Events.generateUserEvent uid Nothing (UserDeleted (tUntagged luid)) embed do -- Note: Connections can only be deleted afterwards, since -- they need to be notified. diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 1e00ed82c76..8f2bb7f827d 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -81,8 +81,6 @@ import Wire.SessionStore import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) import Wire.UserKeyStore import Wire.UserKeyStore.Cassandra -import Wire.UserSearchSubsystem -import Wire.UserSearchSubsystem.Interpreter (interpretUserSearchSubsystem) import Wire.UserStore import Wire.UserStore.Cassandra import Wire.UserSubsystem @@ -101,7 +99,6 @@ type BrigCanonicalEffects = PropertySubsystem, DeleteQueue, Wire.Events.Events, - UserSearchSubsystem, Error UserSubsystemError, Error AuthenticationSubsystemError, Error Wire.API.Federation.Error.FederationError, @@ -237,7 +234,6 @@ runBrigToIO e (AppT ma) = do . mapError (StdError . federationErrorToWai) . mapError authenticationSubsystemErrorToHttpError . mapError userSubsystemErrorToHttpError - . interpretUserSearchSubsystem userSubsystemConfig . runEvents . runDeleteQueue (e ^. internalEvents) . interpretPropertySubsystem propertySubsystemConfig diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 9d3e61d9ecb..73e5a5729b9 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -20,7 +20,7 @@ -- FUTUREWORK: Move to Brig.User.RPC or similar. module Brig.IO.Intra ( -- * Pushing & Journaling Events - onUserEvent, + sendUserEvent, onConnectionEvent, onPropertyEvent, onClientEvent, @@ -104,28 +104,25 @@ import Wire.Rpc import Wire.Sem.Logger qualified as Log import Wire.Sem.Paging qualified as P import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserSearchSubsystem (UserSearchSubsystem) -import Wire.UserSearchSubsystem qualified as UserSearchSubsystem ----------------------------------------------------------------------------- -- Event Handlers -onUserEvent :: +-- TODO: Extract 'journalEvent' out of this +sendUserEvent :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member (ConnectionStore InternalPaging) r ) => UserId -> Maybe ConnId -> UserEvent -> Sem r () -onUserEvent orig conn e = - updateSearchIndex orig e - *> dispatchNotifications orig conn e +sendUserEvent orig conn e = + dispatchNotifications orig conn e *> embed (journalEvent orig e) runEvents :: @@ -134,13 +131,12 @@ runEvents :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member (ConnectionStore InternalPaging) r ) => InterpreterFor Events r runEvents = interpret \case -- FUTUREWORK(mangoiv): should this be in another module? - GenerateUserEvent uid mconnid event -> onUserEvent uid mconnid event + GenerateUserEvent uid mconnid event -> sendUserEvent uid mconnid event GeneratePropertyEvent uid connid event -> onPropertyEvent uid connid event onConnectionEvent :: @@ -195,35 +191,6 @@ onClientEvent orig conn e = do & pushApsData .~ toApsData event ] -updateSearchIndex :: - (Member UserSearchSubsystem r) => - UserId -> - UserEvent -> - Sem r () -updateSearchIndex orig e = case e of - -- no-ops - UserCreated {} -> pure () - UserIdentityUpdated UserIdentityUpdatedData {..} -> do - when (isJust eiuEmail) $ UserSearchSubsystem.syncUser orig - UserIdentityRemoved {} -> pure () - UserLegalHoldDisabled {} -> pure () - UserLegalHoldEnabled {} -> pure () - LegalHoldClientRequested {} -> pure () - UserSuspended {} -> UserSearchSubsystem.syncUser orig - UserResumed {} -> UserSearchSubsystem.syncUser orig - UserActivated {} -> UserSearchSubsystem.syncUser orig - UserDeleted {} -> UserSearchSubsystem.syncUser orig - UserUpdated UserUpdatedData {..} -> do - let interesting = - or - [ isJust eupName, - isJust eupAccentId, - isJust eupHandle, - isJust eupManagedBy, - isJust eupSSOId || eupSSOIdRemoved - ] - when interesting $ UserSearchSubsystem.syncUser orig - journalEvent :: (MonadReader Env m, MonadIO m) => UserId -> UserEvent -> m () journalEvent orig e = case e of UserActivated acc -> diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index df789da38cb..ff03179c43b 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -23,7 +23,6 @@ where import Brig.App (initHttpManagerWithTLSConfig, mkIndexEnv) import Brig.Index.Options import Brig.Options -import Brig.Options qualified as Opt import Brig.User.Search.Index import Cassandra (Client, runClient) import Cassandra.Options @@ -49,7 +48,8 @@ import System.Logger.Class (Logger) import Util.Options (initCredentials) import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error -import Wire.API.User +import Wire.BlockListStore (BlockListStore) +import Wire.BlockListStore.Cassandra import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter (noFederationAPIAccess) import Wire.FederationConfigStore (FederationConfigStore) @@ -66,18 +66,20 @@ import Wire.Sem.Concurrency.IO import Wire.Sem.Logger.TinyLog import Wire.Sem.Metrics import Wire.Sem.Metrics.IO +import Wire.UserKeyStore (UserKeyStore) +import Wire.UserKeyStore.Cassandra import Wire.UserSearch.Migration (MigrationException) -import Wire.UserSearchSubsystem (UserSearchSubsystem, UserSearchSubsystemBulk) +import Wire.UserSearchSubsystem (UserSearchSubsystemBulk) import Wire.UserSearchSubsystem qualified as UserSearchSubsystem import Wire.UserSearchSubsystem.Interpreter import Wire.UserStore import Wire.UserStore.Cassandra import Wire.UserSubsystem.Error -import Wire.UserSubsystem.Interpreter (UserSubsystemConfig (..)) type BrigIndexEffectStack = [ UserSearchSubsystemBulk, - UserSearchSubsystem, + UserKeyStore, + BlockListStore, Error UserSubsystemError, FederationAPIAccess FederatorClient, Error FederationError, @@ -118,15 +120,6 @@ runSem esConn cas galleyEndpoint logger action = do additionalConn = Nothing } reqId = (RequestId "brig-index") - userSubsystemConfig = - -- These values usually come from brig's config, but in the brig-index - -- CLI we don't have this. These are not really used so it doesn't - -- matter, but they could get used in future causing weird issues. - UserSubsystemConfig - { emailVisibilityConfig = EmailVisibleToSelf, - defaultLocale = Opt.defaultUserLocale, - searchSameTeamOnly = False - } runFinal . embedToFinal . unsafelyPerformConcurrency @@ -146,7 +139,8 @@ runSem esConn cas galleyEndpoint logger action = do . throwErrorToIOFinal @FederationError . noFederationAPIAccess . throwErrorToIOFinal @UserSubsystemError - . interpretUserSearchSubsystem userSubsystemConfig + . interpretBlockListStoreToCassandra casClient + . interpretUserKeyStoreCassandra casClient . interpretUserSearchSubsystemBulk $ action diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 291400fff98..b0b7f4377e7 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -19,7 +19,6 @@ module Brig.InternalEvent.Process (onEvent) where import Brig.API.User qualified as API import Brig.App -import Brig.Effects.ConnectionStore import Brig.IO.Intra (rmClient) import Brig.IO.Intra qualified as Intra import Brig.InternalEvent.Types @@ -28,23 +27,20 @@ import Brig.Provider.API qualified as API import Control.Lens (view) import Control.Monad.Catch import Data.ByteString.Conversion -import Data.Qualified (Local) -import Data.Time.Clock (UTCTime) import Imports import Polysemy -import Polysemy.Conc -import Polysemy.Input (Input) +import Polysemy.Conc hiding (Events) import Polysemy.Time import Polysemy.TinyLog as Log import System.Logger.Class (field, msg, val, (~~)) import Wire.API.UserEvent +import Wire.Events (Events) import Wire.NotificationSubsystem import Wire.PropertySubsystem import Wire.Sem.Delay -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore -import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserStore (UserStore) +import Wire.UserSubsystem (UserSubsystem) -- | Handle an internal event. -- @@ -55,13 +51,11 @@ onEvent :: Member TinyLog r, Member Delay r, Member Race r, - Member (Input (Local ())) r, Member UserKeyStore r, - Member (Input UTCTime) r, Member UserStore r, - Member (ConnectionStore InternalPaging) r, Member PropertySubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => InternalNotification -> Sem r () diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 474ceec58bc..7a518193147 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -32,7 +32,6 @@ import Brig.API.User (createUserInviteViaScim, fetchUserIdentity) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App -import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) import Brig.Team.DB qualified as DB @@ -45,15 +44,12 @@ import Control.Monad.Trans.Except (mapExceptT) import Data.ByteString.Conversion (toByteString, toByteString') import Data.Id import Data.List1 qualified as List1 -import Data.Qualified (Local) import Data.Range import Data.Text.Lazy qualified as LT -import Data.Time.Clock (UTCTime) import Data.Tuple.Extra import Imports hiding (head) import Network.Wai.Utilities hiding (code, message) import Polysemy -import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader) import System.Logger.Class qualified as Log @@ -78,13 +74,11 @@ import Wire.API.User qualified as Public import Wire.BlockListStore import Wire.EmailSending (EmailSending) import Wire.Error +import Wire.Events (Events) import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -import Wire.NotificationSubsystem import Wire.Sem.Concurrency -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore -import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserSubsystem servantAPI :: @@ -297,14 +291,10 @@ getInvitationByEmail email = do suspendTeam :: ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member (Concurrency 'Unsafe) r, Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => TeamId -> (Handler r) NoContent @@ -317,14 +307,10 @@ suspendTeam tid = do unsuspendTeam :: ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member (Concurrency 'Unsafe) r, Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => TeamId -> (Handler r) NoContent @@ -338,14 +324,10 @@ unsuspendTeam tid = do changeTeamAccountStatuses :: ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member (Concurrency 'Unsafe) r, Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => TeamId -> AccountStatus -> diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 1bb322753c3..8c9a7b766c2 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -41,7 +41,6 @@ import Brig.Budget import Brig.Data.Activation qualified as Data import Brig.Data.Client import Brig.Data.User qualified as Data -import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Options qualified as Opt import Brig.Types.Intra import Brig.User.Auth.Cookie @@ -58,13 +57,10 @@ import Data.List.NonEmpty qualified as NE import Data.List1 (List1) import Data.List1 qualified as List1 import Data.Misc (PlainTextPassword6) -import Data.Qualified (Local) -import Data.Time.Clock (UTCTime) import Data.ZAuth.Token qualified as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) import Polysemy -import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) @@ -74,14 +70,13 @@ import Wire.API.User import Wire.API.User.Auth import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.Sso +import Wire.Events (Events) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore) -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore -import Wire.UserSearchSubsystem (UserSearchSubsystem) import Wire.UserStore +import Wire.UserSubsystem (UserSubsystem) import Wire.VerificationCode qualified as VerificationCode import Wire.VerificationCodeGen qualified as VerificationCodeGen import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) @@ -91,16 +86,12 @@ login :: forall r. ( Member GalleyAPIAccess r, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, Member PasswordStore r, Member UserKeyStore r, Member UserStore r, Member VerificationCodeSubsystem r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => Login -> CookieType -> @@ -199,12 +190,8 @@ renewAccess :: forall r u a. ( ZAuth.TokenPair u a, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> @@ -235,13 +222,9 @@ revokeAccess u pw cc ll = do -- Internal catchSuspendInactiveUser :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + ( Member TinyLog r, + Member UserSubsystem r, + Member Events r ) => UserId -> e -> @@ -266,12 +249,8 @@ newAccess :: forall u a r. ( ZAuth.TokenPair u a, Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => UserId -> Maybe ClientId -> @@ -368,12 +347,8 @@ validateToken ut at = do -- | Allow to login as any user without having the credentials. ssoLogin :: ( Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => SsoLogin -> CookieType -> @@ -395,13 +370,9 @@ ssoLogin (SsoLogin uid label) typ = do -- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens. legalHoldLogin :: ( Member GalleyAPIAccess r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r, - Member UserSearchSubsystem r + Member UserSubsystem r, + Member Events r ) => LegalHoldLogin -> CookieType -> From d77a0c156a01004083c97942c745d85f8fe7c35b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 10:28:30 +0200 Subject: [PATCH 21/48] Fix merge mistakes --- libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs | 4 ++-- libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 1 - libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index 9209e6e603c..d87abbf2201 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -46,13 +46,13 @@ type instance Name, Writetime Name, Maybe AccountStatus, Maybe (Writetime AccountStatus), Maybe Handle, Maybe (Writetime Handle), - Maybe Email, Maybe (Writetime Email), + Maybe EmailAddress, Maybe (Writetime EmailAddress), ColourId, Writetime ColourId, Activated, Writetime Activated, Maybe ServiceId, Maybe (Writetime ServiceId), Maybe ManagedBy, Maybe (Writetime ManagedBy), Maybe UserSSOId, Maybe (Writetime UserSSOId), - Maybe Email, Maybe (Writetime Email) + Maybe EmailAddress, Maybe (Writetime EmailAddress) ) instance Record IndexUser where diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 78655310574..42e9edd97ee 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -10,7 +10,6 @@ where import Control.Lens (view) import Control.Monad.Trans.Maybe import Data.Domain -import Data.Either.Extra import Data.Handle (Handle) import Data.Handle qualified as Handle import Data.Id diff --git a/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs index 6309b457438..80b3f061742 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs @@ -36,7 +36,7 @@ userDoc1 = udName = Just . Name $ "Carl Phoomp", udNormalized = Just $ "carl phoomp", udHandle = Just . fromJust . parseHandle $ "phoompy", - udEmail = Just $ Email "phoompy" "example.com", + udEmail = Just $ unsafeEmailAddress "phoompy" "example.com", udColourId = Just . ColourId $ 32, udAccountStatus = Just Active, udSAMLIdP = Just "https://issuer.net/214234", From 39b4ea06983edd73e7a83ba781b5c26ff8fa70ae Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 10:36:01 +0200 Subject: [PATCH 22/48] Delete leftover comment --- libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs index 80b3f061742..5e82d9a569e 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSearch/TypesSpec.hs @@ -52,6 +52,3 @@ userDoc1 = -- Dont touch this. This represents serialized legacy data. userDoc1ByteString :: LByteString userDoc1ByteString = "{\"email\":\"phoompy@example.com\",\"account_status\":\"active\",\"handle\":\"phoompy\",\"managed_by\":\"scim\",\"role\":\"admin\",\"accent_id\":32,\"name\":\"Carl Phoomp\",\"created_at\":\"2020-08-29T21:50:00.000Z\",\"team\":\"17c59b18-57d6-11ea-9220-8bbf5eee961a\",\"id\":\"0a96b396-57d6-11ea-a04b-7b93d1a5c19c\",\"normalized\":\"carl phoomp\",\"saml_idp\":\"https://issuer.net/214234\"}" - --- indexUser1 :: IndexUser --- indexUser1 = docToIndex userDoc1 From 01efe6a8f90e39d998185042049e77a2ad131661 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 10:53:05 +0200 Subject: [PATCH 23/48] UserStore.GetIndexUsersPaginated: Allow specifying page size Use 1000 as the size while running index migrations --- .../src/Wire/UserSearchSubsystem/Interpreter.hs | 2 +- libs/wire-subsystems/src/Wire/UserStore.hs | 2 +- libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs | 8 ++++---- .../test/unit/Wire/MockInterpreters/UserStore.hs | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index 8f5354a24a9..93bd4d03d60 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs @@ -73,7 +73,7 @@ syncAllUsersWithVersion :: Sem r () syncAllUsersWithVersion mkVersion = runConduit $ - paginateWithStateC getIndexUsersPaginated + paginateWithStateC (getIndexUsersPaginated 1000) .| logPage .| mkUserDocs .| Conduit.mapM_ IndexedUserStore.bulkUpsert diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 46e274ffacb..41445624a15 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -49,7 +49,7 @@ data StoredUserUpdateError = StoredUserUpdateHandleExists data UserStore m a where GetUser :: UserId -> UserStore m (Maybe StoredUser) GetIndexUser :: UserId -> UserStore m (Maybe IndexUser) - GetIndexUsersPaginated :: Maybe PagingState -> UserStore m (PageWithState IndexUser) + GetIndexUsersPaginated :: Int32 -> Maybe PagingState -> UserStore m (PageWithState IndexUser) UpdateUser :: UserId -> StoredUserUpdate -> UserStore m () UpdateUserHandleEither :: UserId -> StoredUserHandleUpdate -> UserStore m (Either StoredUserUpdateError ()) DeleteUser :: User -> UserStore m () diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 106bbfffa4c..7102ddcb924 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -21,7 +21,7 @@ interpretUserStoreCassandra casClient = runEmbedded (runClient casClient) . embed . \case GetUser uid -> getUserImpl uid GetIndexUser uid -> getIndexUserImpl uid - GetIndexUsersPaginated mPagingState -> getIndexUserPaginatedImpl mPagingState + GetIndexUsersPaginated pageSize mPagingState -> getIndexUserPaginatedImpl pageSize mPagingState UpdateUser uid update -> updateUserImpl uid update UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update DeleteUser user -> deleteUserImpl user @@ -44,9 +44,9 @@ getIndexUserImpl u = do cql :: PrepQuery R (Identity UserId) (TupleType IndexUser) cql = prepared . QueryString $ getIndexUserBaseQuery <> " WHERE id = ?" -getIndexUserPaginatedImpl :: Maybe PagingState -> Client (PageWithState IndexUser) -getIndexUserPaginatedImpl mPagingState = - asRecord <$$> paginateWithState cql (paramsPagingState LocalQuorum () 10000 mPagingState) +getIndexUserPaginatedImpl :: Int32 -> Maybe PagingState -> Client (PageWithState IndexUser) +getIndexUserPaginatedImpl pageSize mPagingState = + asRecord <$$> paginateWithState cql (paramsPagingState LocalQuorum () pageSize mPagingState) where cql :: PrepQuery R () (TupleType IndexUser) cql = prepared $ QueryString getIndexUserBaseQuery diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index c94daea1d75..dbdea470eab 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -32,7 +32,7 @@ inMemoryUserStoreInterpreter = interpret $ \case $ u else u GetIndexUser _uid -> undefined - GetIndexUsersPaginated _pagingState -> undefined + GetIndexUsersPaginated _pageSize _pagingState -> undefined UpdateUserHandleEither uid hUpdate -> runError $ modifyLocalUsers (traverse doUpdate) where doUpdate :: StoredUser -> Sem (Error StoredUserUpdateError : r) StoredUser From c664d34ed004b383dd4a7fc92dc073c150499148 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 14:35:16 +0200 Subject: [PATCH 24/48] wire-subsystems: Fix mock interpreters --- libs/wire-api/src/Wire/API/Team/Feature.hs | 3 ++- .../Wire/MockInterpreters/GalleyAPIAccess.hs | 6 +++++ .../Wire/MockInterpreters/IndexedUserStore.hs | 8 +++--- .../unit/Wire/MockInterpreters/UserStore.hs | 27 ++++++++++++++++++- libs/wire-subsystems/wire-subsystems.cabal | 1 + 5 files changed, 39 insertions(+), 6 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 7c1497edeb4..581c89d7ad3 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -184,7 +184,8 @@ class ( Default cfg, ToSchema cfg, Default (LockableFeature cfg), - KnownSymbol (FeatureSymbol cfg) + KnownSymbol (FeatureSymbol cfg), + NpProject cfg Features ) => IsFeatureConfig cfg where diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 1cfe41aeaf6..9f37e501b4a 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -1,5 +1,7 @@ module Wire.MockInterpreters.GalleyAPIAccess where +import Data.Id +import Data.Proxy import Imports import Polysemy import Wire.API.Team.Feature @@ -16,4 +18,8 @@ miniGalleyAPIAccess :: miniGalleyAPIAccess member configs = interpret $ \case GetTeamMember _ _ -> pure member GetAllTeamFeaturesForUser _ -> pure configs + GetFeatureConfigForTeam tid -> pure $ getFeatureConfigForTeamImpl configs tid _ -> error "uninterpreted effect: GalleyAPIAccess" + +getFeatureConfigForTeamImpl :: forall feature. (IsFeatureConfig feature) => AllTeamFeatures -> TeamId -> LockableFeature feature +getFeatureConfigForTeamImpl allfeatures _ = npProject' (Proxy @(feature)) allfeatures diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs index 70f80eb2a2c..60a186a6d8c 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs @@ -7,9 +7,9 @@ import Wire.IndexedUserStore inMemoryIndexedUserStoreInterpreter :: InterpreterFor IndexedUserStore r inMemoryIndexedUserStoreInterpreter = interpret $ \case - Upsert {} -> error "IndexedUserStore: unimplemented in memory interpreter" - UpdateTeamSearchVisibilityInbound {} -> error "IndexedUserStore: unimplemented in memory interpreter" - BulkUpsert {} -> error "IndexedUserStore: unimplemented in memory interpreter" - DoesIndexExist -> error "IndexedUserStore: unimplemented in memory interpreter" + Upsert {} -> pure () + UpdateTeamSearchVisibilityInbound {} -> pure () + BulkUpsert {} -> pure () + DoesIndexExist -> pure True SearchUsers {} -> error "IndexedUserStore: unimplemented in memory interpreter" PaginateTeamMembers {} -> error "IndexedUserStore: unimplemented in memory interpreter" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index dbdea470eab..6e0efb7df8b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -1,7 +1,10 @@ module Wire.MockInterpreters.UserStore where +import Cassandra.Util import Data.Handle import Data.Id +import Data.Time +import Data.Time.Calendar.OrdinalDate import Imports import Polysemy import Polysemy.Error @@ -10,6 +13,7 @@ import Wire.API.User hiding (DeleteUser) import Wire.API.User qualified as User import Wire.StoredUser import Wire.UserStore +import Wire.UserStore.IndexUser inMemoryUserStoreInterpreter :: forall r. @@ -31,7 +35,8 @@ inMemoryUserStoreInterpreter = interpret $ \case . maybe Imports.id setStoredUserSupportedProtocols update.supportedProtocols $ u else u - GetIndexUser _uid -> undefined + GetIndexUser uid -> + gets $ fmap storedUserToIndexUser . find (\user -> user.id == uid) GetIndexUsersPaginated _pageSize _pagingState -> undefined UpdateUserHandleEither uid hUpdate -> runError $ modifyLocalUsers (traverse doUpdate) where @@ -60,6 +65,26 @@ inMemoryUserStoreInterpreter = interpret $ \case IsActivated uid -> isActivatedImpl uid LookupLocale uid -> lookupLocaleImpl uid +storedUserToIndexUser :: StoredUser -> IndexUser +storedUserToIndexUser storedUser = + -- If we really care about this, we could start storing the writetimes, but we + -- don't need it right now + let withDefaultTime x = WithWriteTime x $ Writetime $ UTCTime (YearDay 0 1) 0 + in IndexUser + { userId = storedUser.id, + teamId = storedUser.teamId, + name = withDefaultTime storedUser.name, + accountStatus = withDefaultTime <$> storedUser.status, + handle = withDefaultTime <$> storedUser.handle, + email = withDefaultTime <$> storedUser.email, + colourId = withDefaultTime storedUser.accentId, + activated = withDefaultTime storedUser.activated, + serviceId = withDefaultTime <$> storedUser.serviceId, + managedBy = withDefaultTime <$> storedUser.managedBy, + ssoId = withDefaultTime <$> storedUser.ssoId, + unverifiedEmail = Nothing + } + lookupLocaleImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe ((Maybe Language, Maybe Country))) lookupLocaleImpl uid = do users <- get diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index d22f373cf27..cbed34f5864 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -257,6 +257,7 @@ test-suite wire-subsystems-tests , base , bilge , bytestring + , cassandra-util , containers , crypton , data-default From 4ec43a246181cff780fe778af144b6d79e8c38a4 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 14:43:14 +0200 Subject: [PATCH 25/48] Dedup IndexError --- services/brig/src/Brig/User/Search/Index.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index f307319a381..09b05d77d23 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -60,6 +60,7 @@ import Prometheus (MonadMonitor) import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..), field, info, msg, val, (+++), (~~)) import Util.Options (Endpoint) +import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..)) import Wire.UserSearch.Types (searchVisibilityInboundFieldName) -------------------------------------------------------------------------------- @@ -193,14 +194,6 @@ analysisSettings = ] in ES.Analysis analyzerDef mempty filterDef mempty -data IndexError - = IndexUpdateError ES.EsError - | IndexLookupError ES.EsError - | IndexError Text - deriving (Show) - -instance Exception IndexError - updateMapping :: (MonadIndexIO m) => m () updateMapping = liftIndexIO $ do idx <- asks idxName From f6146533d78f28d39349cf75fa04223168555e24 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 14:44:52 +0200 Subject: [PATCH 26/48] Remove TODO --- services/brig/src/Brig/IO/Intra.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 73e5a5729b9..484d791f3e2 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -108,7 +108,6 @@ import Wire.Sem.Paging.Cassandra (InternalPaging) ----------------------------------------------------------------------------- -- Event Handlers --- TODO: Extract 'journalEvent' out of this sendUserEvent :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, From 542f5ba1905268dea1ff8fa92b77baa054420a59 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 15:04:39 +0200 Subject: [PATCH 27/48] Reorganize Bulk operations --- .../src/Wire/IndexedUserStore.hs | 8 -------- .../Bulk.hs} | 12 +++++------ .../Bulk/ElasticSearch.hs} | 20 ++++++++++--------- .../Wire/IndexedUserStore/MigrationStore.hs | 13 ++++++++++++ .../ElasticSearch.hs | 4 ++-- libs/wire-subsystems/wire-subsystems.cabal | 7 ++++--- services/brig/src/Brig/Index/Eval.hs | 19 +++++++++--------- 7 files changed, 46 insertions(+), 37 deletions(-) rename libs/wire-subsystems/src/Wire/{UserSearchSubsystem.hs => IndexedUserStore/Bulk.hs} (61%) rename libs/wire-subsystems/src/Wire/{UserSearchSubsystem/Interpreter.hs => IndexedUserStore/Bulk/ElasticSearch.hs} (88%) create mode 100644 libs/wire-subsystems/src/Wire/IndexedUserStore/MigrationStore.hs rename libs/wire-subsystems/src/Wire/IndexedUserStore/{Migration => MigrationStore}/ElasticSearch.hs (96%) diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs index c1900b19915..6f9489923a1 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs @@ -7,7 +7,6 @@ import Database.Bloodhound.Types hiding (SearchResult) import Imports import Polysemy import Wire.API.User.Search -import Wire.UserSearch.Migration import Wire.UserSearch.Types data IndexedUserStore m a where @@ -33,10 +32,3 @@ data IndexedUserStore m a where IndexedUserStore m (SearchResult UserDoc) makeSem ''IndexedUserStore - -data IndexedUserMigrationStore m a where - EnsureMigrationIndex :: IndexedUserMigrationStore m () - GetLatestMigrationVersion :: IndexedUserMigrationStore m MigrationVersion - PersistMigrationVersion :: MigrationVersion -> IndexedUserMigrationStore m () - -makeSem ''IndexedUserMigrationStore diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs similarity index 61% rename from libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs rename to libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs index 831fa8890b8..6fb49336ba0 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs @@ -1,17 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} -module Wire.UserSearchSubsystem where +module Wire.IndexedUserStore.Bulk where import Polysemy -- | Bulk operations, must not be used from any web handler -data UserSearchSubsystemBulk m a where +data IndexedUserStoreBulk m a where -- | Only changes data if it is not updated since last update, use when users -- need to be synced because of an outage, or migrating to a new ES instance. - SyncAllUsers :: UserSearchSubsystemBulk m () + SyncAllUsers :: IndexedUserStoreBulk m () -- | Overwrite all users in the ES index, use it when trying to fix some -- inconsistency or while introducing a new field in the mapping. - ForceSyncAllUsers :: UserSearchSubsystemBulk m () - MigrateData :: UserSearchSubsystemBulk m () + ForceSyncAllUsers :: IndexedUserStoreBulk m () + MigrateData :: IndexedUserStoreBulk m () -makeSem ''UserSearchSubsystemBulk +makeSem ''IndexedUserStoreBulk diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs similarity index 88% rename from libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs rename to libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index 93bd4d03d60..03a50f92c4e 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs @@ -1,4 +1,4 @@ -module Wire.UserSearchSubsystem.Interpreter where +module Wire.IndexedUserStore.Bulk.ElasticSearch where import Cassandra.Exec (paginateWithStateC) import Conduit (ConduitT, runConduit, (.|)) @@ -15,16 +15,18 @@ import Polysemy.TinyLog qualified as Log import System.Logger.Message qualified as Log import Wire.API.Team.Feature import Wire.GalleyAPIAccess -import Wire.IndexedUserStore (IndexedUserMigrationStore, IndexedUserStore) +import Wire.IndexedUserStore (IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore +import Wire.IndexedUserStore.Bulk +import Wire.IndexedUserStore.MigrationStore +import Wire.IndexedUserStore.MigrationStore qualified as MigrationStore import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) import Wire.UserSearch.Migration import Wire.UserSearch.Types -import Wire.UserSearchSubsystem import Wire.UserStore import Wire.UserStore.IndexUser -interpretUserSearchSubsystemBulk :: +interpretIndexedUserStoreBulk :: ( Member TinyLog r, Member UserStore r, Member (Concurrency Unsafe) r, @@ -33,8 +35,8 @@ interpretUserSearchSubsystemBulk :: Member (Error MigrationException) r, Member IndexedUserMigrationStore r ) => - InterpreterFor UserSearchSubsystemBulk r -interpretUserSearchSubsystemBulk = interpret \case + InterpreterFor IndexedUserStoreBulk r +interpretIndexedUserStoreBulk = interpret \case SyncAllUsers -> syncAllUsersImpl ForceSyncAllUsers -> forceSyncAllUsersImpl MigrateData -> migrateDataImpl @@ -106,8 +108,8 @@ migrateDataImpl :: migrateDataImpl = do unlessM IndexedUserStore.doesIndexExist $ throw TargetIndexAbsent - IndexedUserStore.ensureMigrationIndex - foundVersion <- IndexedUserStore.getLatestMigrationVersion + MigrationStore.ensureMigrationIndex + foundVersion <- MigrationStore.getLatestMigrationVersion if expectedMigrationVersion > foundVersion then do Log.info $ @@ -115,7 +117,7 @@ migrateDataImpl = do . Log.field "expectedVersion" expectedMigrationVersion . Log.field "foundVersion" foundVersion forceSyncAllUsersImpl - IndexedUserStore.persistMigrationVersion expectedMigrationVersion + MigrationStore.persistMigrationVersion expectedMigrationVersion else do Log.info $ Log.msg (Log.val "No migration necessary.") diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/MigrationStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/MigrationStore.hs new file mode 100644 index 00000000000..1cb9c8d51f6 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/MigrationStore.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.IndexedUserStore.MigrationStore where + +import Polysemy +import Wire.UserSearch.Migration + +data IndexedUserMigrationStore m a where + EnsureMigrationIndex :: IndexedUserMigrationStore m () + GetLatestMigrationVersion :: IndexedUserMigrationStore m MigrationVersion + PersistMigrationVersion :: MigrationVersion -> IndexedUserMigrationStore m () + +makeSem ''IndexedUserMigrationStore diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Migration/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/MigrationStore/ElasticSearch.hs similarity index 96% rename from libs/wire-subsystems/src/Wire/IndexedUserStore/Migration/ElasticSearch.hs rename to libs/wire-subsystems/src/Wire/IndexedUserStore/MigrationStore/ElasticSearch.hs index 9097fa8c147..9532a54246c 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Migration/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/MigrationStore/ElasticSearch.hs @@ -1,4 +1,4 @@ -module Wire.IndexedUserStore.Migration.ElasticSearch where +module Wire.IndexedUserStore.MigrationStore.ElasticSearch where import Data.Aeson import Data.Text qualified as Text @@ -8,7 +8,7 @@ import Polysemy import Polysemy.Error import Polysemy.TinyLog import System.Logger.Message qualified as Log -import Wire.IndexedUserStore +import Wire.IndexedUserStore.MigrationStore import Wire.Sem.Logger qualified as Log import Wire.UserSearch.Migration diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index cbed34f5864..48efebc5a9a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -94,8 +94,11 @@ library Wire.GundeckAPIAccess Wire.HashPassword Wire.IndexedUserStore + Wire.IndexedUserStore.Bulk + Wire.IndexedUserStore.Bulk.ElasticSearch Wire.IndexedUserStore.ElasticSearch - Wire.IndexedUserStore.Migration.ElasticSearch + Wire.IndexedUserStore.MigrationStore + Wire.IndexedUserStore.MigrationStore.ElasticSearch Wire.InternalEvent Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter @@ -117,8 +120,6 @@ library Wire.UserSearch.Metrics Wire.UserSearch.Migration Wire.UserSearch.Types - Wire.UserSearchSubsystem - Wire.UserSearchSubsystem.Interpreter Wire.UserStore Wire.UserStore.Cassandra Wire.UserStore.IndexUser diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index ff03179c43b..3d1f0c15c22 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -57,8 +57,12 @@ import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc import Wire.IndexedUserStore +import Wire.IndexedUserStore.Bulk (IndexedUserStoreBulk) +import Wire.IndexedUserStore.Bulk qualified as IndexedUserStoreBulk +import Wire.IndexedUserStore.Bulk.ElasticSearch (interpretIndexedUserStoreBulk) import Wire.IndexedUserStore.ElasticSearch -import Wire.IndexedUserStore.Migration.ElasticSearch +import Wire.IndexedUserStore.MigrationStore (IndexedUserMigrationStore) +import Wire.IndexedUserStore.MigrationStore.ElasticSearch import Wire.ParseException import Wire.Rpc import Wire.Sem.Concurrency @@ -69,15 +73,12 @@ import Wire.Sem.Metrics.IO import Wire.UserKeyStore (UserKeyStore) import Wire.UserKeyStore.Cassandra import Wire.UserSearch.Migration (MigrationException) -import Wire.UserSearchSubsystem (UserSearchSubsystemBulk) -import Wire.UserSearchSubsystem qualified as UserSearchSubsystem -import Wire.UserSearchSubsystem.Interpreter import Wire.UserStore import Wire.UserStore.Cassandra import Wire.UserSubsystem.Error type BrigIndexEffectStack = - [ UserSearchSubsystemBulk, + [ IndexedUserStoreBulk, UserKeyStore, BlockListStore, Error UserSubsystemError, @@ -141,7 +142,7 @@ runSem esConn cas galleyEndpoint logger action = do . throwErrorToIOFinal @UserSubsystemError . interpretBlockListStoreToCassandra casClient . interpretUserKeyStoreCassandra casClient - . interpretUserSearchSubsystemBulk + . interpretIndexedUserStoreBulk $ action throwErrorToIOFinal :: (Exception e, Member (Final IO) r) => InterpreterFor (Error e) r @@ -160,16 +161,16 @@ runCommand l = \case runIndexIO e $ resetIndex (mkCreateIndexSettings es) Reindex es cas galley -> do runSem (es ^. esConnection) cas galley l $ - UserSearchSubsystem.syncAllUsers + IndexedUserStoreBulk.syncAllUsers ReindexSameOrNewer es cas galley -> do runSem (es ^. esConnection) cas galley l $ - UserSearchSubsystem.forceSyncAllUsers + IndexedUserStoreBulk.forceSyncAllUsers UpdateMapping esConn galley -> do e <- initIndex esConn galley runIndexIO e updateMapping Migrate es cas galley -> do runSem (es ^. esConnection) cas galley l $ - UserSearchSubsystem.migrateData + IndexedUserStoreBulk.migrateData ReindexFromAnotherIndex reindexSettings -> do mgr <- initHttpManagerWithTLSConfig From 0ec354b1abd23465a0d48c8f608e2e069d40715b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 15:19:48 +0200 Subject: [PATCH 28/48] UserSearch.Types: Remove comment The JSON instances are already not compatible the conversion happens explicitly in application code --- libs/wire-subsystems/src/Wire/UserSearch/Types.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs index 8bc636aea51..fc4d15e434e 100644 --- a/libs/wire-subsystems/src/Wire/UserSearch/Types.hs +++ b/libs/wire-subsystems/src/Wire/UserSearch/Types.hs @@ -63,8 +63,6 @@ data UserDoc = UserDoc deriving (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserDoc) --- Note: Keep this compatible with the FromJSON instances --- of 'Contact' and 'TeamContact' from 'Wire.API.User.Search instance ToJSON UserDoc where toJSON ud = object From 0369090cabdf7f2da55dc837f0e469b49eeecdbd Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 15:34:06 +0200 Subject: [PATCH 29/48] Move expectedMigrationVersion to IndexedUserStore.Bulk --- libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs | 5 +++++ .../src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs | 4 ---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs index 6fb49336ba0..66969fe61d6 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs @@ -3,6 +3,11 @@ module Wire.IndexedUserStore.Bulk where import Polysemy +import Wire.UserSearch.Migration + +-- | Increase this number any time you want to force reindexing. +expectedMigrationVersion :: MigrationVersion +expectedMigrationVersion = MigrationVersion 6 -- | Bulk operations, must not be used from any web handler data IndexedUserStoreBulk m a where diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index 03a50f92c4e..1dc7c618cf6 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs @@ -124,10 +124,6 @@ migrateDataImpl = do . Log.field "expectedVersion" expectedMigrationVersion . Log.field "foundVersion" foundVersion --- | Increase this number any time you want to force reindexing. -expectedMigrationVersion :: MigrationVersion -expectedMigrationVersion = MigrationVersion 6 - -- TODO: This is duplicated in UserSubsystem.Interpreter teamSearchVisibilityInbound :: (Member GalleyAPIAccess r) => TeamId -> Sem r SearchVisibilityInbound teamSearchVisibilityInbound tid = From ec8a5d51f8255e9076c987019d649aae1940d271 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 27 Aug 2024 15:35:57 +0200 Subject: [PATCH 30/48] regen nix --- libs/wire-subsystems/default.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 5e8d703bc6a..689c19e2237 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -170,6 +170,7 @@ mkDerivation { base bilge bytestring + cassandra-util containers crypton data-default From 559e154bc9dadbea79c76d214cfca75eca235077 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 16 Sep 2024 13:52:51 +0200 Subject: [PATCH 31/48] Removed duplicated function. --- .../src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs | 1 - libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 6 +----- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index 1dc7c618cf6..64d36d0d131 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs @@ -124,7 +124,6 @@ migrateDataImpl = do . Log.field "expectedVersion" expectedMigrationVersion . Log.field "foundVersion" foundVersion --- TODO: This is duplicated in UserSubsystem.Interpreter teamSearchVisibilityInbound :: (Member GalleyAPIAccess r) => TeamId -> Sem r SearchVisibilityInbound teamSearchVisibilityInbound tid = searchVisibilityInboundFromFeatureStatus . (.status) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 7e776d1cf96..5e737103467 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -50,6 +50,7 @@ import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.IndexedUserStore (IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore +import Wire.IndexedUserStore.Bulk.ElasticSearch (teamSearchVisibilityInbound) import Wire.InvitationCodeStore (InvitationCodeStore, lookupInvitationByEmail) import Wire.Sem.Concurrency import Wire.Sem.Metrics @@ -567,11 +568,6 @@ syncUserIndex uid = Metrics.incCounter indexUpdateCounter IndexedUserStore.upsert (userIdToDocId uid) userDoc version -teamSearchVisibilityInbound :: (Member GalleyAPIAccess r) => TeamId -> Sem r SearchVisibilityInbound -teamSearchVisibilityInbound tid = - searchVisibilityInboundFromFeatureStatus . (.status) - <$> getFeatureConfigForTeam @_ @SearchVisibilityInboundConfig tid - updateTeamSearchVisibilityInboundImpl :: (Member IndexedUserStore r) => TeamStatus SearchVisibilityInboundConfig -> Sem r () updateTeamSearchVisibilityInboundImpl teamStatus = IndexedUserStore.updateTeamSearchVisibilityInbound teamStatus.team $ From 63e3c4b6c59c1d1697c991361468d0e52c019d34 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 16 Sep 2024 14:49:41 +0200 Subject: [PATCH 32/48] Brig.API.User.onActivated: update the index when email changes --- services/brig/src/Brig/API/User.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 0cbb51b4d71..39fa231d29f 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -758,7 +758,7 @@ onActivated (AccountActivated account) = liftSem $ do Events.generateUserEvent uid Nothing $ UserActivated (accountUser account) pure (uid, userIdentity (accountUser account), True) onActivated (EmailActivated uid email) = do - -- TODO: Looks like a bug to not update the index + liftSem $ User.internalUpdateSearchIndex uid liftSem $ Events.generateUserEvent uid Nothing (emailUpdated uid email) wrapHttpClient $ Data.deleteEmailUnvalidated uid pure (uid, Just (EmailIdentity email), False) From b6f08d22dd429b1886cb18fb17f42e37ac4a9d2b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 16 Sep 2024 16:30:40 +0200 Subject: [PATCH 33/48] Promote suspected bug to confirmed bug, to be solved in a separate ticket --- services/brig/src/Brig/API/User.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 39fa231d29f..88169040128 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -603,8 +603,12 @@ removeEmail uid = do Just (SSOIdentity (UserSSOId _) (Just e)) -> lift $ do liftSem $ deleteKey $ mkEmailKey e wrapClient $ Data.deleteEmail uid - -- TODO: This doesn't delete user's email address from the index, looks - -- like a bug + -- FUTUREWORK: This doesn't delete user's email address from the index, + -- which is a bug, reported here: + -- https://wearezeta.atlassian.net/browse/WPB-11122. + -- + -- Calling User.internalUpdateSearchIndex here wouldn't work as explained + -- in the ticket. liftSem $ Events.generateUserEvent uid Nothing (emailRemoved uid e) Just _ -> throwE LastIdentity Nothing -> throwE NoIdentity From 66a97d723bdb8e4322433e66e6e954a77612a7cb Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 16 Sep 2024 17:06:25 +0200 Subject: [PATCH 34/48] Another bug reported for another ticket --- libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index d87abbf2201..523e9d8f767 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -122,7 +122,8 @@ indexUserToDoc searchVisInbound IndexUser {..} = udSso = sso . value =<< ssoId, udScimExternalId = join $ scimExternalId <$> (value <$> managedBy) <*> (value <$> ssoId), udSearchVisibilityInbound = Just searchVisInbound, - udRole = Nothing, -- TODO: This looks weird, why do we have this? + -- FUTUREWORK: This is a bug: https://wearezeta.atlassian.net/browse/WPB-11124 + udRole = Nothing, udCreatedAt = Just . toUTCTimeMillis $ writetimeToUTC activated.writetime, udManagedBy = value <$> managedBy, udSAMLIdP = idpUrl . value =<< ssoId, From ede2aa14a7dc572e338246a3dc80f0dfcfdb95f4 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 08:24:57 +0200 Subject: [PATCH 35/48] hi ci From 1806e821129aa3523e7380af94561553b50e8640 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 10:16:37 +0200 Subject: [PATCH 36/48] Resolve todo: Moved a function, drive-by clean-up of lenses overuse. --- libs/wire-api/src/Wire/API/Team/Member.hs | 8 +- libs/wire-api/src/Wire/API/Team/Permission.hs | 16 +- .../Wire/API/Golden/Generated/Event_team.hs | 8 +- .../Golden/Generated/NewTeamMember_team.hs | 68 ++--- .../API/Golden/Generated/Permissions_team.hs | 78 +++--- .../Golden/Generated/TeamMemberList_team.hs | 234 +++++++++--------- .../API/Golden/Generated/TeamMember_team.hs | 70 +++--- .../test/unit/Test/Wire/API/Team/Member.hs | 23 +- .../src/Wire/IndexedUserStore.hs | 9 + .../Wire/IndexedUserStore/ElasticSearch.hs | 8 - .../wire-subsystems/src/Wire/UserSubsystem.hs | 51 ++++ .../src/Wire/UserSubsystem/Interpreter.hs | 20 -- services/brig/brig.cabal | 1 - services/brig/src/Brig/API/Public.hs | 42 ++-- services/brig/src/Brig/Provider/API.hs | 42 +++- services/brig/src/Brig/Team/API.hs | 57 +++-- services/brig/src/Brig/Team/Util.hs | 57 ----- services/brig/src/Brig/User/Search/Index.hs | 2 +- .../brig/src/Brig/User/Search/SearchIndex.hs | 6 +- .../brig/src/Brig/User/Search/TeamSize.hs | 3 +- services/galley/galley.cabal | 1 - .../src/V1_BackfillBillingTeamMembers.hs | 3 +- services/galley/src/Galley/API/Teams.hs | 4 +- services/galley/src/Galley/Cassandra/Team.hs | 2 +- 24 files changed, 413 insertions(+), 400 deletions(-) delete mode 100644 services/brig/src/Brig/Team/Util.hs diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index d94cbfecc32..98720fab69b 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -585,10 +585,10 @@ class IsPerm perm where instance IsPerm Perm where type PermError p = 'MissingPermission ('Just p) - roleHasPerm r p = p `Set.member` (rolePermissions r ^. self) - roleGrantsPerm r p = p `Set.member` (rolePermissions r ^. copy) - hasPermission tm p = p `Set.member` (tm ^. permissions . self) - mayGrantPermission tm p = p `Set.member` (tm ^. permissions . copy) + roleHasPerm r p = p `Set.member` ((rolePermissions r).self) + roleGrantsPerm r p = p `Set.member` ((rolePermissions r).copy) + hasPermission tm p = p `Set.member` ((tm ^. permissions).self) + mayGrantPermission tm p = p `Set.member` ((tm ^. permissions).copy) instance IsPerm HiddenPerm where type PermError p = OperationDenied diff --git a/libs/wire-api/src/Wire/API/Team/Permission.hs b/libs/wire-api/src/Wire/API/Team/Permission.hs index b4ac0d90455..f8d5ba61fa7 100644 --- a/libs/wire-api/src/Wire/API/Team/Permission.hs +++ b/libs/wire-api/src/Wire/API/Team/Permission.hs @@ -26,8 +26,6 @@ module Wire.API.Team.Permission ( -- * Permissions Permissions (..), - self, - copy, newPermissions, fullPermissions, noPermissions, @@ -45,7 +43,7 @@ where import Cassandra qualified as Cql import Control.Error.Util qualified as Err -import Control.Lens (makeLenses, (?~), (^.)) +import Control.Lens ((?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Bits (testBit, (.|.)) import Data.OpenApi qualified as S @@ -61,8 +59,8 @@ import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) -- Permissions data Permissions = Permissions - { _self :: Set Perm, - _copy :: Set Perm + { self :: Set Perm, + copy :: Set Perm } deriving stock (Eq, Ord, Show, Generic) deriving (FromJSON, ToJSON, S.ToSchema) via (Schema Permissions) @@ -71,8 +69,8 @@ permissionsSchema :: ValueSchema NamedSwaggerDoc Permissions permissionsSchema = objectWithDocModifier "Permissions" (description ?~ docs) $ Permissions - <$> (permsToInt . _self) .= field "self" (intToPerms <$> schema) - <*> (permsToInt . _copy) .= field "copy" (intToPerms <$> schema) + <$> (permsToInt . self) .= field "self" (intToPerms <$> schema) + <*> (permsToInt . copy) .= field "copy" (intToPerms <$> schema) where docs = "This is just a complicated way of representing a team role. self and copy \ @@ -198,14 +196,12 @@ intToPerm 0x0800 = Just DeleteTeam intToPerm 0x1000 = Just SetMemberPermissions intToPerm _ = Nothing -makeLenses ''Permissions - instance Cql.Cql Permissions where ctype = Cql.Tagged $ Cql.UdtColumn "permissions" [("self", Cql.BigIntColumn), ("copy", Cql.BigIntColumn)] toCql p = let f = Cql.CqlBigInt . fromIntegral . permsToInt - in Cql.CqlUdt [("self", f (p ^. self)), ("copy", f (p ^. copy))] + in Cql.CqlUdt [("self", f (p.self)), ("copy", f (p.copy))] fromCql (Cql.CqlUdt p) = do let f = intToPerms . fromIntegral :: Int64 -> Set.Set Perm diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs index c80d19bea0e..7a9dbb790c1 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs @@ -230,7 +230,7 @@ testObject_Event_team_18 = (Id (fromJust (UUID.fromString "00007783-0000-7d60-0000-00d30000396e"))) ( Just ( Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -246,7 +246,7 @@ testObject_Event_team_18 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ CreateConversation, DeleteConversation, @@ -273,7 +273,7 @@ testObject_Event_team_19 = (Id (fromJust (UUID.fromString "0000382c-0000-1ce7-0000-568b00001fe9"))) ( Just ( Permissions - { _self = + { self = fromList [ DeleteConversation, RemoveTeamMember, @@ -284,7 +284,7 @@ testObject_Event_team_19 = GetMemberPermissions, GetTeamConversations ], - _copy = + copy = fromList [ DeleteConversation, RemoveTeamMember, diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs index 34294b4bd00..0c5db95a9d3 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs @@ -41,14 +41,14 @@ import Wire.API.Team.Permission SetMemberPermissions, SetTeamData ), - Permissions (Permissions, _copy, _self), + Permissions (Permissions, copy, self), ) testObject_NewTeamMember_team_1 :: NewTeamMember testObject_NewTeamMember_team_1 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0007-0000-000200000002"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000004")), fromJust (readUTCTimeMillis "1864-05-04T12:59:54.182Z") @@ -60,7 +60,7 @@ testObject_NewTeamMember_team_2 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000004-0000-0000-0000-000200000003"))) ( Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -69,7 +69,7 @@ testObject_NewTeamMember_team_2 = AddRemoveConvMember, ModifyConvName ], - _copy = fromList [DeleteConversation, AddRemoveConvMember] + copy = fromList [DeleteConversation, AddRemoveConvMember] } ) ( Just @@ -83,10 +83,10 @@ testObject_NewTeamMember_team_3 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0008-0000-000700000005"))) ( Permissions - { _self = + { self = fromList [CreateConversation, DeleteConversation, RemoveTeamMember, GetBilling, DeleteTeam], - _copy = fromList [CreateConversation, DeleteConversation, GetBilling] + copy = fromList [CreateConversation, DeleteConversation, GetBilling] } ) ( Just @@ -100,8 +100,8 @@ testObject_NewTeamMember_team_4 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000700000005"))) ( Permissions - { _self = fromList [CreateConversation, AddTeamMember, SetTeamData], - _copy = fromList [CreateConversation, SetTeamData] + { self = fromList [CreateConversation, AddTeamMember, SetTeamData], + copy = fromList [CreateConversation, SetTeamData] } ) Nothing @@ -110,7 +110,7 @@ testObject_NewTeamMember_team_5 :: NewTeamMember testObject_NewTeamMember_team_5 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002"))) - (Permissions {_self = fromList [AddTeamMember, SetBilling, GetTeamConversations], _copy = fromList [AddTeamMember]}) + (Permissions {self = fromList [AddTeamMember, SetBilling, GetTeamConversations], copy = fromList [AddTeamMember]}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000600000006")), fromJust (readUTCTimeMillis "1864-05-12T23:29:05.832Z") @@ -122,10 +122,10 @@ testObject_NewTeamMember_team_6 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0006-0000-000400000003"))) ( Permissions - { _self = + { self = fromList [CreateConversation, DeleteConversation, GetBilling, SetTeamData, SetMemberPermissions], - _copy = fromList [CreateConversation, GetBilling] + copy = fromList [CreateConversation, GetBilling] } ) ( Just @@ -139,10 +139,10 @@ testObject_NewTeamMember_team_7 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000007-0000-0004-0000-000500000005"))) ( Permissions - { _self = + { self = fromList [AddTeamMember, RemoveTeamMember, ModifyConvName, GetTeamConversations, DeleteTeam], - _copy = fromList [AddTeamMember] + copy = fromList [AddTeamMember] } ) ( Just @@ -156,8 +156,8 @@ testObject_NewTeamMember_team_8 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0003-0000-000200000003"))) ( Permissions - { _self = fromList [ModifyConvName], - _copy = fromList [ModifyConvName] + { self = fromList [ModifyConvName], + copy = fromList [ModifyConvName] } ) ( Just @@ -170,7 +170,7 @@ testObject_NewTeamMember_team_9 :: NewTeamMember testObject_NewTeamMember_team_9 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0008-0000-000300000004"))) - (Permissions {_self = fromList [SetBilling], _copy = fromList []}) + (Permissions {self = fromList [SetBilling], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000700000000")), fromJust (readUTCTimeMillis "1864-05-08T10:27:23.240Z") @@ -181,7 +181,7 @@ testObject_NewTeamMember_team_10 :: NewTeamMember testObject_NewTeamMember_team_10 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0003-0000-000600000003"))) - (Permissions {_self = fromList [GetBilling], _copy = fromList []}) + (Permissions {self = fromList [GetBilling], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000004-0000-0006-0000-000600000008")), fromJust (readUTCTimeMillis "1864-05-15T10:49:54.418Z") @@ -193,8 +193,8 @@ testObject_NewTeamMember_team_11 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000006-0000-0005-0000-000000000002"))) ( Permissions - { _self = fromList [CreateConversation, ModifyConvName, SetTeamData], - _copy = fromList [] + { self = fromList [CreateConversation, ModifyConvName, SetTeamData], + copy = fromList [] } ) ( Just @@ -207,7 +207,7 @@ testObject_NewTeamMember_team_12 :: NewTeamMember testObject_NewTeamMember_team_12 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0004-0000-000000000007"))) - (Permissions {_self = fromList [SetBilling, SetTeamData, GetTeamConversations], _copy = fromList []}) + (Permissions {self = fromList [SetBilling, SetTeamData, GetTeamConversations], copy = fromList []}) Nothing testObject_NewTeamMember_team_13 :: NewTeamMember @@ -215,8 +215,8 @@ testObject_NewTeamMember_team_13 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0004-0000-000600000001"))) ( Permissions - { _self = fromList [AddTeamMember, AddRemoveConvMember, SetTeamData, GetTeamConversations], - _copy = fromList [AddTeamMember, AddRemoveConvMember, GetTeamConversations] + { self = fromList [AddTeamMember, AddRemoveConvMember, SetTeamData, GetTeamConversations], + copy = fromList [AddTeamMember, AddRemoveConvMember, GetTeamConversations] } ) Nothing @@ -226,10 +226,10 @@ testObject_NewTeamMember_team_14 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000500000004"))) ( Permissions - { _self = + { self = fromList [CreateConversation, DeleteConversation, ModifyConvName, GetBilling], - _copy = fromList [] + copy = fromList [] } ) ( Just @@ -243,8 +243,8 @@ testObject_NewTeamMember_team_15 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0008-0000-000800000007"))) ( Permissions - { _self = fromList [RemoveTeamMember, GetMemberPermissions, DeleteTeam], - _copy = fromList [RemoveTeamMember, GetMemberPermissions] + { self = fromList [RemoveTeamMember, GetMemberPermissions, DeleteTeam], + copy = fromList [RemoveTeamMember, GetMemberPermissions] } ) ( Just @@ -258,8 +258,8 @@ testObject_NewTeamMember_team_16 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0006-0000-000300000005"))) ( Permissions - { _self = fromList [CreateConversation, RemoveTeamMember, GetBilling, GetTeamConversations, DeleteTeam], - _copy = fromList [] + { self = fromList [CreateConversation, RemoveTeamMember, GetBilling, GetTeamConversations, DeleteTeam], + copy = fromList [] } ) Nothing @@ -268,7 +268,7 @@ testObject_NewTeamMember_team_17 :: NewTeamMember testObject_NewTeamMember_team_17 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0008-0000-000400000005"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000004-0000-0008-0000-000800000007")), fromJust (readUTCTimeMillis "1864-05-07T21:53:30.897Z") @@ -279,7 +279,7 @@ testObject_NewTeamMember_team_18 :: NewTeamMember testObject_NewTeamMember_team_18 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000006-0000-0003-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000500000002")), fromJust (readUTCTimeMillis "1864-05-11T12:32:01.417Z") @@ -291,8 +291,8 @@ testObject_NewTeamMember_team_19 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000004-0000-0005-0000-000100000008"))) ( Permissions - { _self = fromList [DeleteConversation, RemoveTeamMember, SetBilling, SetMemberPermissions], - _copy = fromList [DeleteConversation, SetBilling] + { self = fromList [DeleteConversation, RemoveTeamMember, SetBilling, SetMemberPermissions], + copy = fromList [DeleteConversation, SetBilling] } ) Nothing @@ -302,7 +302,7 @@ testObject_NewTeamMember_team_20 = mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000000000004"))) ( Permissions - { _self = + { self = fromList [ AddTeamMember, AddRemoveConvMember, @@ -311,7 +311,7 @@ testObject_NewTeamMember_team_20 = GetMemberPermissions, GetTeamConversations ], - _copy = fromList [] + copy = fromList [] } ) ( Just diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Permissions_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Permissions_team.hs index fd47570ce6c..2403aff6562 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Permissions_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Permissions_team.hs @@ -40,12 +40,12 @@ import Wire.API.Team.Permission ) testObject_Permissions_team_1 :: Permissions -testObject_Permissions_team_1 = Permissions {_self = fromList [SetBilling], _copy = fromList [SetBilling]} +testObject_Permissions_team_1 = Permissions {self = fromList [SetBilling], copy = fromList [SetBilling]} testObject_Permissions_team_2 :: Permissions testObject_Permissions_team_2 = Permissions - { _self = + { self = fromList [ DeleteConversation, AddTeamMember, @@ -58,7 +58,7 @@ testObject_Permissions_team_2 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ DeleteConversation, AddTeamMember, @@ -75,7 +75,7 @@ testObject_Permissions_team_2 = testObject_Permissions_team_3 :: Permissions testObject_Permissions_team_3 = Permissions - { _self = + { self = fromList [ DeleteConversation, AddTeamMember, @@ -87,7 +87,7 @@ testObject_Permissions_team_3 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ AddTeamMember, RemoveTeamMember, @@ -102,7 +102,7 @@ testObject_Permissions_team_3 = testObject_Permissions_team_4 :: Permissions testObject_Permissions_team_4 = Permissions - { _self = + { self = fromList [ DeleteConversation, AddTeamMember, @@ -113,13 +113,13 @@ testObject_Permissions_team_4 = SetMemberPermissions, DeleteTeam ], - _copy = fromList [GetBilling] + copy = fromList [GetBilling] } testObject_Permissions_team_5 :: Permissions testObject_Permissions_team_5 = Permissions - { _self = + { self = fromList [ CreateConversation, AddTeamMember, @@ -131,7 +131,7 @@ testObject_Permissions_team_5 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ CreateConversation, RemoveTeamMember, @@ -145,7 +145,7 @@ testObject_Permissions_team_5 = testObject_Permissions_team_6 :: Permissions testObject_Permissions_team_6 = Permissions - { _self = + { self = fromList [ CreateConversation, AddTeamMember, @@ -158,7 +158,7 @@ testObject_Permissions_team_6 = GetMemberPermissions, GetTeamConversations ], - _copy = + copy = fromList [ CreateConversation, AddTeamMember, @@ -175,7 +175,7 @@ testObject_Permissions_team_6 = testObject_Permissions_team_7 :: Permissions testObject_Permissions_team_7 = Permissions - { _self = + { self = fromList [ AddTeamMember, RemoveTeamMember, @@ -186,13 +186,13 @@ testObject_Permissions_team_7 = GetTeamConversations, DeleteTeam ], - _copy = fromList [AddRemoveConvMember, GetBilling, DeleteTeam] + copy = fromList [AddRemoveConvMember, GetBilling, DeleteTeam] } testObject_Permissions_team_8 :: Permissions testObject_Permissions_team_8 = Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -207,7 +207,7 @@ testObject_Permissions_team_8 = SetMemberPermissions, GetTeamConversations ], - _copy = + copy = fromList [ AddTeamMember, RemoveTeamMember, @@ -222,20 +222,20 @@ testObject_Permissions_team_8 = testObject_Permissions_team_9 :: Permissions testObject_Permissions_team_9 = Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, AddRemoveConvMember, GetMemberPermissions ], - _copy = fromList [CreateConversation, AddRemoveConvMember, GetMemberPermissions] + copy = fromList [CreateConversation, AddRemoveConvMember, GetMemberPermissions] } testObject_Permissions_team_10 :: Permissions testObject_Permissions_team_10 = Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -247,7 +247,7 @@ testObject_Permissions_team_10 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ CreateConversation, DeleteConversation, @@ -264,7 +264,7 @@ testObject_Permissions_team_10 = testObject_Permissions_team_11 :: Permissions testObject_Permissions_team_11 = Permissions - { _self = + { self = fromList [ DeleteConversation, RemoveTeamMember, @@ -274,13 +274,13 @@ testObject_Permissions_team_11 = GetTeamConversations, DeleteTeam ], - _copy = fromList [RemoveTeamMember, GetMemberPermissions, GetTeamConversations] + copy = fromList [RemoveTeamMember, GetMemberPermissions, GetTeamConversations] } testObject_Permissions_team_12 :: Permissions testObject_Permissions_team_12 = Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -295,7 +295,7 @@ testObject_Permissions_team_12 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ CreateConversation, DeleteConversation, @@ -314,7 +314,7 @@ testObject_Permissions_team_12 = testObject_Permissions_team_13 :: Permissions testObject_Permissions_team_13 = Permissions - { _self = + { self = fromList [ CreateConversation, AddTeamMember, @@ -324,13 +324,13 @@ testObject_Permissions_team_13 = SetTeamData, SetMemberPermissions ], - _copy = fromList [SetTeamData, SetMemberPermissions] + copy = fromList [SetTeamData, SetMemberPermissions] } testObject_Permissions_team_14 :: Permissions testObject_Permissions_team_14 = Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -342,7 +342,7 @@ testObject_Permissions_team_14 = GetMemberPermissions, SetMemberPermissions ], - _copy = + copy = fromList [ CreateConversation, DeleteConversation, @@ -359,7 +359,7 @@ testObject_Permissions_team_14 = testObject_Permissions_team_15 :: Permissions testObject_Permissions_team_15 = Permissions - { _self = + { self = fromList [ DeleteConversation, AddTeamMember, @@ -371,13 +371,13 @@ testObject_Permissions_team_15 = SetMemberPermissions, DeleteTeam ], - _copy = fromList [] + copy = fromList [] } testObject_Permissions_team_16 :: Permissions testObject_Permissions_team_16 = Permissions - { _self = + { self = fromList [ DeleteConversation, AddRemoveConvMember, @@ -386,7 +386,7 @@ testObject_Permissions_team_16 = SetMemberPermissions, GetTeamConversations ], - _copy = + copy = fromList [DeleteConversation, GetBilling, SetTeamData, SetMemberPermissions, GetTeamConversations] } @@ -394,7 +394,7 @@ testObject_Permissions_team_16 = testObject_Permissions_team_17 :: Permissions testObject_Permissions_team_17 = Permissions - { _self = + { self = fromList [ DeleteConversation, AddTeamMember, @@ -406,7 +406,7 @@ testObject_Permissions_team_17 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ DeleteConversation, AddTeamMember, @@ -423,7 +423,7 @@ testObject_Permissions_team_17 = testObject_Permissions_team_18 :: Permissions testObject_Permissions_team_18 = Permissions - { _self = + { self = fromList [ CreateConversation, AddTeamMember, @@ -433,7 +433,7 @@ testObject_Permissions_team_18 = SetMemberPermissions, DeleteTeam ], - _copy = + copy = fromList [ CreateConversation, AddTeamMember, @@ -447,7 +447,7 @@ testObject_Permissions_team_18 = testObject_Permissions_team_19 :: Permissions testObject_Permissions_team_19 = Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -462,7 +462,7 @@ testObject_Permissions_team_19 = GetTeamConversations, DeleteTeam ], - _copy = + copy = fromList [ CreateConversation, DeleteConversation, @@ -479,7 +479,7 @@ testObject_Permissions_team_19 = testObject_Permissions_team_20 :: Permissions testObject_Permissions_team_20 = Permissions - { _self = + { self = fromList [ CreateConversation, DeleteConversation, @@ -491,7 +491,7 @@ testObject_Permissions_team_20 = SetMemberPermissions, DeleteTeam ], - _copy = + copy = fromList [ DeleteConversation, AddTeamMember, diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs index b540677bd5e..55838c4d159 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs @@ -47,7 +47,7 @@ import Wire.API.Team.Permission SetMemberPermissions, SetTeamData ), - Permissions (Permissions, _copy, _self), + Permissions (Permissions, copy, self), ) testObject_TeamMemberList_team_1 :: TeamMemberList @@ -58,7 +58,7 @@ testObject_TeamMemberList_team_2 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000000000002"))) - (Permissions {_self = fromList [GetBilling, SetMemberPermissions], _copy = fromList []}) + (Permissions {self = fromList [GetBilling, SetMemberPermissions], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000002")), fromJust (readUTCTimeMillis "1864-05-10T10:05:44.332Z") @@ -73,7 +73,7 @@ testObject_TeamMemberList_team_3 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T06:07:36.175Z") @@ -82,7 +82,7 @@ testObject_TeamMemberList_team_3 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T14:28:10.448Z") @@ -91,7 +91,7 @@ testObject_TeamMemberList_team_3 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T16:05:37.642Z") @@ -100,12 +100,12 @@ testObject_TeamMemberList_team_3 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T13:06:20.504Z") @@ -114,7 +114,7 @@ testObject_TeamMemberList_team_3 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T16:37:10.774Z") @@ -123,7 +123,7 @@ testObject_TeamMemberList_team_3 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T04:36:55.388Z") @@ -138,7 +138,7 @@ testObject_TeamMemberList_team_4 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [GetTeamConversations], _copy = fromList []}) + (Permissions {self = fromList [GetTeamConversations], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-08T16:05:11.696Z") @@ -147,7 +147,7 @@ testObject_TeamMemberList_team_4 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-08T07:09:26.753Z") @@ -162,7 +162,7 @@ testObject_TeamMemberList_team_5 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T23:10:04.963Z") @@ -171,7 +171,7 @@ testObject_TeamMemberList_team_5 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T15:40:17.119Z") @@ -180,7 +180,7 @@ testObject_TeamMemberList_team_5 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T00:40:38.004Z") @@ -189,7 +189,7 @@ testObject_TeamMemberList_team_5 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T07:30:49.028Z") @@ -204,7 +204,7 @@ testObject_TeamMemberList_team_6 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T17:07:48.156Z") @@ -213,7 +213,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T00:04:10.559Z") @@ -222,7 +222,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T10:39:19.860Z") @@ -231,7 +231,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T13:40:56.648Z") @@ -240,7 +240,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T12:13:40.273Z") @@ -249,7 +249,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T13:28:04.561Z") @@ -258,7 +258,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T02:59:55.584Z") @@ -267,7 +267,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T22:57:33.947Z") @@ -276,7 +276,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T01:02:39.691Z") @@ -285,7 +285,7 @@ testObject_TeamMemberList_team_6 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T13:39:38.488Z") @@ -300,12 +300,12 @@ testObject_TeamMemberList_team_7 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [SetTeamData], _copy = fromList []}) + (Permissions {self = fromList [SetTeamData], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-10T03:11:36.961Z") @@ -314,7 +314,7 @@ testObject_TeamMemberList_team_7 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldEnabled ] @@ -325,7 +325,7 @@ testObject_TeamMemberList_team_8 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T07:35:03.629Z") @@ -334,7 +334,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T00:48:38.818Z") @@ -343,7 +343,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T06:12:10.151Z") @@ -352,7 +352,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T03:45:53.520Z") @@ -361,7 +361,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T17:14:59.798Z") @@ -370,7 +370,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T17:51:55.340Z") @@ -379,7 +379,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T01:38:35.880Z") @@ -388,7 +388,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T18:06:10.660Z") @@ -397,7 +397,7 @@ testObject_TeamMemberList_team_8 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T07:30:46.880Z") @@ -406,12 +406,12 @@ testObject_TeamMemberList_team_8 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending ] @@ -422,7 +422,7 @@ testObject_TeamMemberList_team_9 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [AddTeamMember], _copy = fromList []}) + (Permissions {self = fromList [AddTeamMember], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-08T22:16:59.050Z") @@ -431,7 +431,7 @@ testObject_TeamMemberList_team_9 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [CreateConversation], _copy = fromList []}) + (Permissions {self = fromList [CreateConversation], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-08T21:43:37.550Z") @@ -446,7 +446,7 @@ testObject_TeamMemberList_team_10 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T04:44:28.366Z") @@ -455,7 +455,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T06:22:04.036Z") @@ -464,7 +464,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T12:10:11.701Z") @@ -473,7 +473,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T21:54:05.305Z") @@ -482,7 +482,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T00:26:06.221Z") @@ -491,12 +491,12 @@ testObject_TeamMemberList_team_10 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T20:12:04.856Z") @@ -505,7 +505,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T23:35:44.986Z") @@ -514,7 +514,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T07:36:17.730Z") @@ -523,7 +523,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T19:36:57.529Z") @@ -532,12 +532,12 @@ testObject_TeamMemberList_team_10 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T19:45:56.914Z") @@ -546,7 +546,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T13:42:17.107Z") @@ -555,7 +555,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T03:42:46.106Z") @@ -564,7 +564,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T09:41:44.679Z") @@ -573,7 +573,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T09:26:44.717Z") @@ -582,7 +582,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T00:40:00.056Z") @@ -591,12 +591,12 @@ testObject_TeamMemberList_team_10 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T07:47:20.635Z") @@ -605,7 +605,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T15:58:21.895Z") @@ -614,7 +614,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T19:25:51.873Z") @@ -623,7 +623,7 @@ testObject_TeamMemberList_team_10 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T03:19:55.569Z") @@ -638,7 +638,7 @@ testObject_TeamMemberList_team_11 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T06:08:50.626Z") @@ -647,12 +647,12 @@ testObject_TeamMemberList_team_11 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T08:23:53.653Z") @@ -661,12 +661,12 @@ testObject_TeamMemberList_team_11 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T16:28:42.815Z") @@ -675,17 +675,17 @@ testObject_TeamMemberList_team_11 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T11:47:57.498Z") @@ -694,7 +694,7 @@ testObject_TeamMemberList_team_11 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T17:22:07.538Z") @@ -703,7 +703,7 @@ testObject_TeamMemberList_team_11 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T19:14:48.836Z") @@ -712,7 +712,7 @@ testObject_TeamMemberList_team_11 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T14:53:49.059Z") @@ -721,7 +721,7 @@ testObject_TeamMemberList_team_11 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T10:44:04.209Z") @@ -730,7 +730,7 @@ testObject_TeamMemberList_team_11 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T23:34:24.831Z") @@ -745,12 +745,12 @@ testObject_TeamMemberList_team_12 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T15:59:09.462Z") @@ -759,12 +759,12 @@ testObject_TeamMemberList_team_12 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T00:27:17.631Z") @@ -779,12 +779,12 @@ testObject_TeamMemberList_team_13 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [GetMemberPermissions], _copy = fromList []}) + (Permissions {self = fromList [GetMemberPermissions], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-10T04:37:19.686Z") @@ -793,7 +793,7 @@ testObject_TeamMemberList_team_13 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T13:22:20.368Z") @@ -808,12 +808,12 @@ testObject_TeamMemberList_team_14 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T07:01:56.077Z") @@ -822,7 +822,7 @@ testObject_TeamMemberList_team_14 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T09:34:46.900Z") @@ -831,7 +831,7 @@ testObject_TeamMemberList_team_14 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T10:40:24.034Z") @@ -840,7 +840,7 @@ testObject_TeamMemberList_team_14 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T10:17:53.056Z") @@ -849,7 +849,7 @@ testObject_TeamMemberList_team_14 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T18:37:38.894Z") @@ -858,12 +858,12 @@ testObject_TeamMemberList_team_14 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T06:25:10.534Z") @@ -872,7 +872,7 @@ testObject_TeamMemberList_team_14 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T02:42:16.433Z") @@ -881,7 +881,7 @@ testObject_TeamMemberList_team_14 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T07:25:18.248Z") @@ -890,12 +890,12 @@ testObject_TeamMemberList_team_14 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T15:31:36.237Z") @@ -904,7 +904,7 @@ testObject_TeamMemberList_team_14 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T15:23:38.616Z") @@ -913,12 +913,12 @@ testObject_TeamMemberList_team_14 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldEnabled ] @@ -929,7 +929,7 @@ testObject_TeamMemberList_team_15 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T20:33:17.912Z") @@ -938,7 +938,7 @@ testObject_TeamMemberList_team_15 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), fromJust (readUTCTimeMillis "1864-05-09T09:03:59.579Z") @@ -947,17 +947,17 @@ testObject_TeamMemberList_team_15 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled ] @@ -971,7 +971,7 @@ testObject_TeamMemberList_team_17 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T10:04:36.715Z") @@ -980,12 +980,12 @@ testObject_TeamMemberList_team_17 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T03:02:37.641Z") @@ -994,7 +994,7 @@ testObject_TeamMemberList_team_17 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T23:21:44.944Z") @@ -1003,7 +1003,7 @@ testObject_TeamMemberList_team_17 = UserLegalHoldDisabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T08:47:48.774Z") @@ -1018,7 +1018,7 @@ testObject_TeamMemberList_team_18 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T17:44:12.611Z") @@ -1027,7 +1027,7 @@ testObject_TeamMemberList_team_18 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T05:14:06.040Z") @@ -1036,7 +1036,7 @@ testObject_TeamMemberList_team_18 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), fromJust (readUTCTimeMillis "1864-05-09T05:24:40.864Z") @@ -1045,7 +1045,7 @@ testObject_TeamMemberList_team_18 = UserLegalHoldPending, mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-09T20:09:48.156Z") @@ -1054,7 +1054,7 @@ testObject_TeamMemberList_team_18 = UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), fromJust (readUTCTimeMillis "1864-05-09T20:09:31.059Z") @@ -1070,8 +1070,8 @@ testObject_TeamMemberList_team_19 = [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000000"))) ( Permissions - { _self = fromList [CreateConversation, SetTeamData, SetMemberPermissions], - _copy = fromList [] + { self = fromList [CreateConversation, SetTeamData, SetMemberPermissions], + copy = fromList [] } ) ( Just @@ -1088,12 +1088,12 @@ testObject_TeamMemberList_team_20 = newTeamMemberList [ mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) Nothing UserLegalHoldEnabled, mkTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) - (Permissions {_self = fromList [], _copy = fromList []}) + (Permissions {self = fromList [], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), fromJust (readUTCTimeMillis "1864-05-08T15:41:51.601Z") diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs index 358b5cf8810..b810a1cc093 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs @@ -48,7 +48,7 @@ import Wire.API.Team.Permission SetMemberPermissions, SetTeamData ), - Permissions (Permissions, _copy, _self), + Permissions (Permissions, copy, self), ) testObject_TeamMember_team_1 :: TeamMember @@ -56,8 +56,8 @@ testObject_TeamMember_team_1 = mkTeamMember (Id (fromJust (UUID.fromString "00000007-0000-0005-0000-000500000002"))) ( Permissions - { _self = fromList [GetBilling, GetMemberPermissions, SetMemberPermissions, DeleteTeam], - _copy = fromList [GetBilling] + { self = fromList [GetBilling, GetMemberPermissions, SetMemberPermissions, DeleteTeam], + copy = fromList [GetBilling] } ) ( Just @@ -71,7 +71,7 @@ testObject_TeamMember_team_2 :: TeamMember testObject_TeamMember_team_2 = mkTeamMember (Id (fromJust (UUID.fromString "00000003-0000-0000-0000-000500000005"))) - (Permissions {_self = fromList [ModifyConvName, SetMemberPermissions], _copy = fromList []}) + (Permissions {self = fromList [ModifyConvName, SetMemberPermissions], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000004")), fromJust (readUTCTimeMillis "1864-05-03T14:56:52.508Z") @@ -84,10 +84,10 @@ testObject_TeamMember_team_3 = mkTeamMember (Id (fromJust (UUID.fromString "00000005-0000-0003-0000-000400000003"))) ( Permissions - { _self = + { self = fromList [DeleteConversation, AddTeamMember, AddRemoveConvMember, GetBilling], - _copy = fromList [GetBilling] + copy = fromList [GetBilling] } ) ( Just @@ -102,8 +102,8 @@ testObject_TeamMember_team_4 = mkTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0005-0000-000100000006"))) ( Permissions - { _self = fromList [ModifyConvName, SetMemberPermissions], - _copy = fromList [SetMemberPermissions] + { self = fromList [ModifyConvName, SetMemberPermissions], + copy = fromList [SetMemberPermissions] } ) ( Just @@ -118,8 +118,8 @@ testObject_TeamMember_team_5 = mkTeamMember (Id (fromJust (UUID.fromString "00000007-0000-0000-0000-000200000001"))) ( Permissions - { _self = fromList [DeleteConversation, GetBilling, SetBilling, GetMemberPermissions], - _copy = fromList [DeleteConversation, GetMemberPermissions] + { self = fromList [DeleteConversation, GetBilling, SetBilling, GetMemberPermissions], + copy = fromList [DeleteConversation, GetMemberPermissions] } ) ( Just @@ -134,10 +134,10 @@ testObject_TeamMember_team_6 = mkTeamMember (Id (fromJust (UUID.fromString "00000006-0000-0007-0000-000800000005"))) ( Permissions - { _self = + { self = fromList [CreateConversation, AddTeamMember, AddRemoveConvMember, SetBilling, SetTeamData], - _copy = fromList [] + copy = fromList [] } ) ( Just @@ -152,7 +152,7 @@ testObject_TeamMember_team_7 = mkTeamMember (Id (fromJust (UUID.fromString "00000007-0000-0000-0000-000200000001"))) ( Permissions - { _self = + { self = fromList [ DeleteConversation, AddRemoveConvMember, @@ -160,7 +160,7 @@ testObject_TeamMember_team_7 = SetMemberPermissions, GetTeamConversations ], - _copy = fromList [] + copy = fromList [] } ) Nothing @@ -171,7 +171,7 @@ testObject_TeamMember_team_8 = mkTeamMember (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000300000000"))) ( Permissions - { _self = + { self = fromList [ AddRemoveConvMember, ModifyConvName, @@ -179,7 +179,7 @@ testObject_TeamMember_team_8 = SetMemberPermissions, DeleteTeam ], - _copy = fromList [] + copy = fromList [] } ) ( Just @@ -194,8 +194,8 @@ testObject_TeamMember_team_9 = mkTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0006-0000-000300000003"))) ( Permissions - { _self = fromList [AddTeamMember, ModifyConvName], - _copy = fromList [ModifyConvName] + { self = fromList [AddTeamMember, ModifyConvName], + copy = fromList [ModifyConvName] } ) Nothing @@ -205,7 +205,7 @@ testObject_TeamMember_team_10 :: TeamMember testObject_TeamMember_team_10 = mkTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000100000006"))) - (Permissions {_self = fromList [DeleteConversation, AddTeamMember], _copy = fromList []}) + (Permissions {self = fromList [DeleteConversation, AddTeamMember], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000008-0000-0005-0000-000000000002")), fromJust (readUTCTimeMillis "1864-05-03T19:02:13.669Z") @@ -218,9 +218,9 @@ testObject_TeamMember_team_11 = mkTeamMember (Id (fromJust (UUID.fromString "00000004-0000-0001-0000-000400000007"))) ( Permissions - { _self = + { self = fromList [CreateConversation, DeleteConversation, SetTeamData, SetMemberPermissions], - _copy = fromList [] + copy = fromList [] } ) ( Just @@ -234,7 +234,7 @@ testObject_TeamMember_team_12 :: TeamMember testObject_TeamMember_team_12 = mkTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0006-0000-000200000005"))) - (Permissions {_self = fromList [GetTeamConversations], _copy = fromList []}) + (Permissions {self = fromList [GetTeamConversations], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000005-0000-0001-0000-000300000003")), fromJust (readUTCTimeMillis "1864-05-10T22:34:18.259Z") @@ -246,7 +246,7 @@ testObject_TeamMember_team_13 :: TeamMember testObject_TeamMember_team_13 = mkTeamMember (Id (fromJust (UUID.fromString "00000006-0000-0001-0000-000800000006"))) - (Permissions {_self = fromList [CreateConversation, GetMemberPermissions], _copy = fromList [CreateConversation]}) + (Permissions {self = fromList [CreateConversation, GetMemberPermissions], copy = fromList [CreateConversation]}) ( Just ( Id (fromJust (UUID.fromString "00000000-0000-0003-0000-000400000007")), fromJust (readUTCTimeMillis "1864-05-06T08:18:27.514Z") @@ -259,8 +259,8 @@ testObject_TeamMember_team_14 = mkTeamMember (Id (fromJust (UUID.fromString "00000004-0000-0000-0000-000300000007"))) ( Permissions - { _self = fromList [DeleteConversation, AddTeamMember, GetBilling, GetMemberPermissions], - _copy = fromList [GetBilling, GetMemberPermissions] + { self = fromList [DeleteConversation, AddTeamMember, GetBilling, GetMemberPermissions], + copy = fromList [GetBilling, GetMemberPermissions] } ) ( Just @@ -274,7 +274,7 @@ testObject_TeamMember_team_15 :: TeamMember testObject_TeamMember_team_15 = mkTeamMember (Id (fromJust (UUID.fromString "00000005-0000-0006-0000-000800000006"))) - (Permissions {_self = fromList [DeleteTeam], _copy = fromList [DeleteTeam]}) + (Permissions {self = fromList [DeleteTeam], copy = fromList [DeleteTeam]}) ( Just ( Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000500000003")), fromJust (readUTCTimeMillis "1864-05-04T06:15:13.870Z") @@ -286,7 +286,7 @@ testObject_TeamMember_team_16 :: TeamMember testObject_TeamMember_team_16 = mkTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0008-0000-000200000008"))) - (Permissions {_self = fromList [DeleteConversation, GetTeamConversations], _copy = fromList []}) + (Permissions {self = fromList [DeleteConversation, GetTeamConversations], copy = fromList []}) ( Just ( Id (fromJust (UUID.fromString "00000006-0000-0000-0000-000400000002")), fromJust (readUTCTimeMillis "1864-05-10T04:27:37.101Z") @@ -299,7 +299,7 @@ testObject_TeamMember_team_17 = mkTeamMember (Id (fromJust (UUID.fromString "00000006-0000-0006-0000-000500000007"))) ( Permissions - { _self = + { self = fromList [ AddRemoveConvMember, ModifyConvName, @@ -307,7 +307,7 @@ testObject_TeamMember_team_17 = SetTeamData, GetTeamConversations ], - _copy = fromList [AddRemoveConvMember] + copy = fromList [AddRemoveConvMember] } ) ( Just @@ -322,9 +322,9 @@ testObject_TeamMember_team_18 = mkTeamMember (Id (fromJust (UUID.fromString "00000005-0000-0005-0000-000200000008"))) ( Permissions - { _self = + { self = fromList [RemoveTeamMember, ModifyConvName, GetMemberPermissions, SetMemberPermissions], - _copy = fromList [SetMemberPermissions] + copy = fromList [SetMemberPermissions] } ) ( Just @@ -339,9 +339,9 @@ testObject_TeamMember_team_19 = mkTeamMember (Id (fromJust (UUID.fromString "00000003-0000-0002-0000-000200000008"))) ( Permissions - { _self = + { self = fromList [AddTeamMember, ModifyConvName, GetBilling, SetBilling, SetMemberPermissions], - _copy = fromList [SetMemberPermissions] + copy = fromList [SetMemberPermissions] } ) ( Just @@ -356,8 +356,8 @@ testObject_TeamMember_team_20 = mkTeamMember (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000100000005"))) ( Permissions - { _self = fromList [CreateConversation, AddTeamMember, ModifyConvName, GetBilling], - _copy = fromList [] + { self = fromList [CreateConversation, AddTeamMember, ModifyConvName, GetBilling], + copy = fromList [] } ) ( Just diff --git a/libs/wire-api/test/unit/Test/Wire/API/Team/Member.hs b/libs/wire-api/test/unit/Test/Wire/API/Team/Member.hs index 8a44da25f23..9795ac54f6c 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Team/Member.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Team/Member.hs @@ -21,7 +21,6 @@ module Test.Wire.API.Team.Member (tests) where -import Control.Lens ((^.)) import Data.Aeson import Data.Set (isSubsetOf) import Data.Set qualified as Set @@ -57,8 +56,8 @@ permissionTests = -- now it's true, and it's nice to have that written down somewhere. forM_ [(r1, r2) | r1 <- [minBound ..], r2 <- drop 1 [r1 ..]] $ \(r1, r2) -> do - assertBool "owner.self" ((rolePermissions r2 ^. self) `isSubsetOf` (rolePermissions r1 ^. self)) - assertBool "owner.copy" ((rolePermissions r2 ^. copy) `isSubsetOf` (rolePermissions r1 ^. copy)), + assertBool "owner.self" (((rolePermissions r2).self) `isSubsetOf` ((rolePermissions r1).self)) + assertBool "owner.copy" (((rolePermissions r2).copy) `isSubsetOf` ((rolePermissions r1).copy)), testGroup "permissionsRole, rolePermissions" [ testCase "'Role' maps to expected permissions" $ do @@ -76,15 +75,15 @@ permissionTests = case permissionsRole perms of Just role -> do let perms' = rolePermissions role - assertEqual "eq" (perms' ^. self) (perms' ^. copy) - assertBool "self" ((perms' ^. self) `Set.isSubsetOf` (perms ^. self)) - assertBool "copy" ((perms' ^. copy) `Set.isSubsetOf` (perms ^. copy)) + assertEqual "eq" perms'.self perms'.copy + assertBool "self" (perms'.self `Set.isSubsetOf` perms.self) + assertBool "copy" (perms'.copy `Set.isSubsetOf` perms.copy) Nothing -> do let leastPermissions = rolePermissions maxBound assertBool "no role for perms, but strictly more perms than max role" $ not - ( (leastPermissions ^. self) `Set.isSubsetOf` w - && (leastPermissions ^. copy) `Set.isSubsetOf` w' + ( (leastPermissions.self) `Set.isSubsetOf` w + && (leastPermissions.copy) `Set.isSubsetOf` w' ) ] ] @@ -93,8 +92,8 @@ permissionConversionTests :: TestTree permissionConversionTests = testGroup "permsToInt / rolePermissions / serialization of `Role`s" - [ testCase "partner" $ assertEqual "" (permsToInt . _self $ rolePermissions RoleExternalPartner) 1025, - testCase "member" $ assertEqual "" (permsToInt . _self $ rolePermissions RoleMember) 1587, - testCase "admin" $ assertEqual "" (permsToInt . _self $ rolePermissions RoleAdmin) 5951, - testCase "owner" $ assertEqual "" (permsToInt . _self $ rolePermissions RoleOwner) 8191 + [ testCase "partner" $ assertEqual "" (permsToInt . self $ rolePermissions RoleExternalPartner) 1025, + testCase "member" $ assertEqual "" (permsToInt . self $ rolePermissions RoleMember) 1587, + testCase "admin" $ assertEqual "" (permsToInt . self $ rolePermissions RoleAdmin) 5951, + testCase "owner" $ assertEqual "" (permsToInt . self $ rolePermissions RoleOwner) 8191 ] diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs index 6f9489923a1..92e3c7ea97e 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs @@ -3,12 +3,21 @@ module Wire.IndexedUserStore where import Data.Id +import Database.Bloodhound qualified as ES import Database.Bloodhound.Types hiding (SearchResult) import Imports import Polysemy import Wire.API.User.Search import Wire.UserSearch.Types +data IndexedUserStoreError + = IndexUpdateError ES.EsError + | IndexLookupError ES.EsError + | IndexError Text + deriving (Show) + +instance Exception IndexedUserStoreError + data IndexedUserStore m a where Upsert :: DocId -> UserDoc -> VersionControl -> IndexedUserStore m () UpdateTeamSearchVisibilityInbound :: diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index a2bf68148d5..f299017ce2b 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -36,14 +36,6 @@ data IndexedUserStoreConfig = IndexedUserStoreConfig additionalConn :: Maybe ESConn } -data IndexedUserStoreError - = IndexUpdateError ES.EsError - | IndexLookupError ES.EsError - | IndexError Text - deriving (Show) - -instance Exception IndexedUserStoreError - interpretIndexedUserStoreES :: ( Member (Embed IO) r, Member Metrics r diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 518f442d8b1..f4106f116e0 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -14,16 +14,23 @@ import Data.HavePendingInvitations import Data.Id import Data.Qualified import Data.Range +import Data.Set qualified as Set import Imports import Polysemy +import Polysemy.Error import Wire.API.Federation.Error import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) import Wire.API.Team.Feature +import Wire.API.Team.Member (IsPerm (..), TeamMember) +import Wire.API.Team.Permission import Wire.API.User import Wire.API.User.Search import Wire.Arbitrary +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.UserKeyStore (EmailKey, emailKeyOrig) import Wire.UserSearch.Types +import Wire.UserSubsystem.Error (UserSubsystemError (..)) -- | Who is performing this update operation / who is allowed to? (Single source of truth: -- users managed by SCIM can't be updated by clients and vice versa.) @@ -170,3 +177,47 @@ getLocalAccountBy includePendingInvitations uid = getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe UserAccount) getLocalUserAccountByUserKey q@(tUnqualified -> ek) = listToMaybe . fmap (.account) <$> getExtendedAccountsByEmailNoFilter (qualifyAs q [emailKeyOrig ek]) + +------------------------------------------ +-- FUTUREWORK: Pending functions for a team subsystem +------------------------------------------ + +ensurePermissions :: + ( IsPerm perm, + Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r + ) => + UserId -> + TeamId -> + [perm] -> + Sem r () +ensurePermissions u t perms = do + m <- GalleyAPIAccess.getTeamMember u t + unless (check m) $ + throw UserSubsystemInsufficientTeamPermissions + where + check :: Maybe TeamMember -> Bool + check (Just m) = all (hasPermission m) perms + check Nothing = False + +-- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). +-- +-- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. +ensurePermissionToAddUser :: + ( Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r + ) => + UserId -> + TeamId -> + Permissions -> + Sem r () +ensurePermissionToAddUser u t inviteePerms = do + minviter <- GalleyAPIAccess.getTeamMember u t + unless (check minviter) $ + throw UserSubsystemInsufficientTeamPermissions + where + check :: Maybe TeamMember -> Bool + check (Just inviter) = + hasPermission inviter AddTeamMember + && all (mayGrantPermission inviter) (Set.toList (inviteePerms.self)) + check Nothing = False diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 5e737103467..8e087904d37 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -752,26 +752,6 @@ browseTeamImpl uid filters mMaxResults mPagingState = do let maxResults = maybe 15 fromRange mMaxResults userDocToTeamContact <$$> IndexedUserStore.paginateTeamMembers filters maxResults mPagingState --- TODO: Move this somewhere more appropriate as this function is broader than --- just the UserSubsystem -ensurePermissions :: - ( IsPerm perm, - Member GalleyAPIAccess r, - Member (Error UserSubsystemError) r - ) => - UserId -> - TeamId -> - [perm] -> - Sem r () -ensurePermissions u t perms = do - m <- GalleyAPIAccess.getTeamMember u t - unless (check m) $ - throw UserSubsystemInsufficientTeamPermissions - where - check :: Maybe TeamMember -> Bool - check (Just m) = all (hasPermission m) perms - check Nothing = False - getAccountNoFilterImpl :: forall r. ( Member UserStore r, diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index a77cdffe110..a3b372717ff 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -186,7 +186,6 @@ library Brig.Team.API Brig.Team.Email Brig.Team.Template - Brig.Team.Util Brig.Template Brig.User.API.Handle Brig.User.Auth diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 5e09beec6ef..715df744b9d 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -86,8 +86,10 @@ import Data.ZAuth.Token qualified as ZAuth import FileEmbedLzma import Imports hiding (head) import Network.Socket (PortNumber) -import Network.Wai.Utilities as Utilities +import Network.Wai.Utilities (CacheControl (..), (!>>)) +import Network.Wai.Utilities qualified as Utilities import Polysemy +import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) @@ -164,6 +166,7 @@ import Wire.UserSearch.Types import Wire.UserStore (UserStore) import Wire.UserSubsystem hiding (checkHandle, checkHandles) import Wire.UserSubsystem qualified as User +import Wire.UserSubsystem.Error import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem @@ -260,35 +263,36 @@ internalEndpointsSwaggerDocsAPI service examplePort swagger Nothing = servantSitemap :: forall r p. - ( Member BlockListStore r, - Member DeleteQueue r, - Member (Concurrency 'Unsafe) r, + ( Member (Concurrency 'Unsafe) r, Member (Embed HttpClientIO) r, - Member (Input (Local ())) r, Member (Embed IO) r, - Member FederationConfigStore r, + Member (Error UserSubsystemError) r, + Member (Input (Local ())) r, + Member (Input TeamTemplates) r, + Member (UserPendingActivationStore p) r, Member AuthenticationSubsystem r, - Member Jwk r, + Member DeleteQueue r, + Member EmailSending r, + Member EmailSubsystem r, + Member Events r, + Member FederationConfigStore r, Member GalleyAPIAccess r, + Member InvitationCodeStore r, + Member Jwk r, Member JwtTools r, Member NotificationSubsystem r, - Member UserSubsystem r, - Member UserStore r, - Member PasswordStore r, - Member UserKeyStore r, Member Now r, + Member PasswordResetCodeStore r, + Member PasswordStore r, + Member PropertySubsystem r, Member PublicKeyBundle r, Member SFT r, Member TinyLog r, - Member (UserPendingActivationStore p) r, - Member EmailSubsystem r, - Member EmailSending r, + Member UserKeyStore r, + Member UserStore r, + Member UserSubsystem r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r, - Member Events r, - Member PasswordResetCodeStore r, - Member InvitationCodeStore r, - Member (Input TeamTemplates) r + Member BlockListStore r ) => ServerT BrigAPI (Handler r) servantSitemap = diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 6a36c4f5a1a..3948bdd8000 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -42,7 +42,6 @@ import Brig.Provider.DB (ServiceConn (..)) import Brig.Provider.DB qualified as DB import Brig.Provider.Email import Brig.Provider.RPC qualified as RPC -import Brig.Team.Util import Brig.ZAuth qualified as ZAuth import Cassandra (MonadClient) import Control.Error (throwE) @@ -81,6 +80,7 @@ import OpenSSL.PEM qualified as SSL import OpenSSL.RSA qualified as SSL import OpenSSL.Random (randBytes) import Polysemy +import Polysemy.Error import Servant (ServerT, (:<|>) (..)) import Ssl.Util qualified as SSL import System.Logger.Class (MonadLogger) @@ -123,6 +123,8 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe)) import Wire.UserKeyStore (mkEmailKey) +import Wire.UserSubsystem +import Wire.UserSubsystem.Error import Wire.VerificationCode as VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem @@ -147,7 +149,10 @@ botAPI = :<|> Named @"bot-get-user-clients" botGetUserClients servicesAPI :: - (Member GalleyAPIAccess r, Member DeleteQueue r) => + ( Member GalleyAPIAccess r, + Member DeleteQueue r, + Member (Error UserSubsystemError) r + ) => ServerT ServicesAPI (Handler r) servicesAPI = Named @"post-provider-services" addService @@ -163,7 +168,12 @@ servicesAPI = :<|> Named @"get-whitelisted-services-by-team-id" searchTeamServiceProfiles :<|> Named @"post-team-whitelist-by-team-id" updateServiceWhitelist -providerAPI :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => ServerT ProviderAPI (Handler r) +providerAPI :: + ( Member GalleyAPIAccess r, + Member EmailSending r, + Member VerificationCodeSubsystem r + ) => + ServerT ProviderAPI (Handler r) providerAPI = Named @"provider-register" newAccount :<|> Named @"provider-activate" activateAccountKey @@ -177,13 +187,23 @@ providerAPI = :<|> Named @"provider-get-account" getAccount :<|> Named @"provider-get-profile" getProviderProfile -internalProviderAPI :: (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => ServerT BrigIRoutes.ProviderAPI (Handler r) +internalProviderAPI :: + ( Member GalleyAPIAccess r, + Member VerificationCodeSubsystem r + ) => + ServerT BrigIRoutes.ProviderAPI (Handler r) internalProviderAPI = Named @"get-provider-activation-code" getActivationCodeH -------------------------------------------------------------------------------- -- Public API (Unauthenticated) -newAccount :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => Public.NewProvider -> (Handler r) Public.NewProviderResponse +newAccount :: + ( Member GalleyAPIAccess r, + Member EmailSending r, + Member VerificationCodeSubsystem r + ) => + Public.NewProvider -> + (Handler r) Public.NewProviderResponse newAccount new = do guardSecondFactorDisabled Nothing let email = (Public.newProviderEmail new) @@ -579,14 +599,22 @@ getServiceTagList _ = do where allTags = [(minBound :: Public.ServiceTag) ..] -updateServiceWhitelist :: (Member GalleyAPIAccess r) => UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp +updateServiceWhitelist :: + ( Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r + ) => + UserId -> + ConnId -> + TeamId -> + Public.UpdateServiceWhitelist -> + (Handler r) UpdateServiceWhitelistResp updateServiceWhitelist uid con tid upd = do guardSecondFactorDisabled (Just uid) let pid = updateServiceWhitelistProvider upd sid = updateServiceWhitelistService upd newWhitelisted = updateServiceWhitelistStatus upd -- Preconditions - ensurePermissions uid tid (Set.toList serviceWhitelistPermissions) + lift . liftSem $ ensurePermissions uid tid (Set.toList serviceWhitelistPermissions) _ <- wrapClientE (DB.lookupService pid sid) >>= maybeServiceNotFound -- Add to various tables whitelisted <- wrapClientE $ DB.getServiceWhitelistStatus tid pid sid diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index b66a4f3f7e5..4ef9c9e275d 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -37,7 +37,6 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options import Brig.Team.Email import Brig.Team.Template -import Brig.Team.Util (ensurePermissionToAddUser, ensurePermissions) import Brig.Types.Team (TeamSize) import Brig.User.Search.TeamSize qualified as TeamSize import Control.Lens (view, (^.)) @@ -53,8 +52,9 @@ import Data.Text.Lazy qualified as LT import Data.Text.Lazy qualified as Text import Data.Tuple.Extra import Imports hiding (head) -import Network.Wai.Utilities hiding (code, message) +import Network.Wai.Utilities hiding (Error, code, message) import Polysemy +import Polysemy.Error import Polysemy.Input (Input, input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log @@ -95,6 +95,7 @@ import Wire.PasswordStore import Wire.Sem.Concurrency import Wire.UserKeyStore import Wire.UserSubsystem +import Wire.UserSubsystem.Error servantAPI :: ( Member GalleyAPIAccess r, @@ -106,7 +107,8 @@ servantAPI :: Member TinyLog r, Member PasswordStore r, Member (Input TeamTemplates) r, - Member Events r + Member Events r, + Member (Error UserSubsystemError) r ) => ServerT TeamsAPI (Handler r) servantAPI = @@ -119,9 +121,16 @@ servantAPI = :<|> Named @"get-team-size" teamSizePublic :<|> Named @"accept-team-invitation" acceptTeamInvitationByPersonalUser -teamSizePublic :: (Member GalleyAPIAccess r) => UserId -> TeamId -> (Handler r) TeamSize +teamSizePublic :: + ( Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r + ) => + UserId -> + TeamId -> + (Handler r) TeamSize teamSizePublic uid tid = do - ensurePermissions uid tid [AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks + -- limit this to team admins to reduce risk of involuntary DOS attacks + lift . liftSem $ ensurePermissions uid tid [AddTeamMember] teamSize tid teamSize :: TeamId -> (Handler r) TeamSize @@ -150,7 +159,8 @@ createInvitation :: Member EmailSending r, Member TinyLog r, Member (Input (Local ())) r, - Member (Input TeamTemplates) r + Member (Input TeamTemplates) r, + Member (Error UserSubsystemError) r ) => UserId -> TeamId -> @@ -162,7 +172,7 @@ createInvitation uid tid body = do let inviteePerms = Teams.rolePermissions inviteeRole idt <- maybe (throwStd (errorToWai @'E.NoIdentity)) pure =<< lift (fetchUserIdentity uid) from <- maybe (throwStd (errorToWai @'E.NoEmail)) pure (emailIdentity idt) - ensurePermissionToAddUser uid tid inviteePerms + lift . liftSem $ ensurePermissionToAddUser uid tid inviteePerms pure $ CreateInvitationInviter uid from let context = @@ -314,14 +324,17 @@ isPersonalUser uke = do && isNothing account.accountUser.userTeam deleteInvitation :: - (Member GalleyAPIAccess r, Member InvitationCodeStore r) => + ( Member GalleyAPIAccess r, + Member InvitationCodeStore r, + Member (Error UserSubsystemError) r + ) => UserId -> TeamId -> InvitationId -> (Handler r) () -deleteInvitation uid tid iid = do +deleteInvitation uid tid iid = (lift . liftSem) do ensurePermissions uid tid [AddTeamMember] - lift . liftSem $ Store.deleteInvitation tid iid + Store.deleteInvitation tid iid listInvitations :: forall r. @@ -330,23 +343,24 @@ listInvitations :: Member InvitationCodeStore r, Member (Input TeamTemplates) r, Member (Input (Local ())) r, - Member UserSubsystem r + Member UserSubsystem r, + Member (Error UserSubsystemError) r ) => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList -listInvitations uid tid startingId mSize = do +listInvitations uid tid startingId mSize = (lift . liftSem) do ensurePermissions uid tid [AddTeamMember] - showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid + showInvitationUrl <- GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid let toInvitations is = mapM (toInvitationHack showInvitationUrl) is - lift (liftSem $ Store.lookupInvitationsPaginated mSize tid startingId) >>= \case + Store.lookupInvitationsPaginated mSize tid startingId >>= \case PaginatedResultHasMore storedInvs -> do - invs <- lift . liftSem $ toInvitations storedInvs + invs <- toInvitations storedInvs pure $ InvitationList invs True PaginatedResult storedInvs -> do - invs <- lift . liftSem $ toInvitations storedInvs + invs <- toInvitations storedInvs pure $ InvitationList invs False where -- To create the correct team invitation URL, we need to detect whether the invited account already exists. @@ -441,21 +455,22 @@ getInvitation :: ( Member GalleyAPIAccess r, Member InvitationCodeStore r, Member TinyLog r, - Member (Input TeamTemplates) r + Member (Input TeamTemplates) r, + Member (Error UserSubsystemError) r ) => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) -getInvitation uid tid iid = do +getInvitation uid tid iid = (lift . liftSem) do ensurePermissions uid tid [AddTeamMember] - invitationM <- lift . liftSem $ Store.lookupInvitation tid iid + invitationM <- Store.lookupInvitation tid iid case invitationM of Nothing -> pure Nothing Just invitation -> do - showInvitationUrl <- lift . liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - maybeUrl <- lift . liftSem $ mkInviteUrl showInvitationUrl tid invitation.code + showInvitationUrl <- GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid + maybeUrl <- mkInviteUrl showInvitationUrl tid invitation.code pure $ Just (Store.invitationFromStored maybeUrl invitation) getInvitationByCode :: diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs deleted file mode 100644 index 428c9abaf98..00000000000 --- a/services/brig/src/Brig/Team/Util.hs +++ /dev/null @@ -1,57 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Team.Util where -- TODO: remove this module and move contents to Brig.IO.Intra? - -import Brig.API.Error -import Brig.App -import Control.Error -import Control.Lens -import Data.Id -import Data.Set qualified as Set -import Imports -import Polysemy (Member) -import Wire.API.Team.Member -import Wire.API.Team.Permission -import Wire.Error -import Wire.GalleyAPIAccess (GalleyAPIAccess) -import Wire.GalleyAPIAccess qualified as GalleyAPIAccess - -ensurePermissions :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> TeamId -> [perm] -> ExceptT HttpError (AppT r) () -ensurePermissions u t perms = do - m <- lift $ liftSem $ GalleyAPIAccess.getTeamMember u t - unless (check m) $ - throwStd insufficientTeamPermissions - where - check :: Maybe TeamMember -> Bool - check (Just m) = all (hasPermission m) perms - check Nothing = False - --- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). --- --- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: (Member GalleyAPIAccess r) => UserId -> TeamId -> Permissions -> ExceptT HttpError (AppT r) () -ensurePermissionToAddUser u t inviteePerms = do - minviter <- lift $ liftSem $ GalleyAPIAccess.getTeamMember u t - unless (check minviter) $ - throwStd insufficientTeamPermissions - where - check :: Maybe TeamMember -> Bool - check (Just inviter) = - hasPermission inviter AddTeamMember - && all (mayGrantPermission inviter) (Set.toList (inviteePerms ^. self)) - check Nothing = False diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index 09b05d77d23..a067b296324 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -60,7 +60,7 @@ import Prometheus (MonadMonitor) import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..), field, info, msg, val, (+++), (~~)) import Util.Options (Endpoint) -import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..)) +import Wire.IndexedUserStore (IndexedUserStoreError (..)) import Wire.UserSearch.Types (searchVisibilityInboundFieldName) -------------------------------------------------------------------------------- diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index 5089dbc6a9c..cde45a8a362 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -37,9 +37,9 @@ import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) import Wire.API.User (ColourId (..), Name (fromName)) import Wire.API.User.Search --- TODO: importing interpreters here is not ideal, perhaps much of this code --- will go into the interpreter in following commits. -import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..), mappingName) +import Wire.IndexedUserStore (IndexedUserStoreError (..)) +-- TODO: Move all this code to the interpreter instead of importing it? +import Wire.IndexedUserStore.ElasticSearch (mappingName) import Wire.UserSearch.Types import Wire.UserStore.IndexUser (normalized) diff --git a/services/brig/src/Brig/User/Search/TeamSize.hs b/services/brig/src/Brig/User/Search/TeamSize.hs index 54bf2522a5b..6121ec38178 100644 --- a/services/brig/src/Brig/User/Search/TeamSize.hs +++ b/services/brig/src/Brig/User/Search/TeamSize.hs @@ -28,8 +28,7 @@ import Control.Monad.Catch (throwM) import Data.Id import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) --- TODO: Not ideal to import interpreters -import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreError (..)) +import Wire.IndexedUserStore (IndexedUserStoreError (..)) teamSize :: (MonadIndexIO m) => TeamId -> m TeamSize teamSize t = liftIndexIO $ do diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 790607e9bf6..1f3c18ac626 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -575,7 +575,6 @@ executable galley-migrate-data , exceptions , extended , imports - , lens , optparse-applicative , text , time diff --git a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs index 7d46e3f8f13..6903c066cc1 100644 --- a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs +++ b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs @@ -19,7 +19,6 @@ module V1_BackfillBillingTeamMembers where import Cassandra import Conduit -import Control.Lens (view) import Data.Conduit.Internal (zipSources) import Data.Conduit.List qualified as C import Data.Id @@ -70,5 +69,5 @@ createBillingTeamMembers pair = cql = "INSERT INTO billing_team_member (team, user) values (?, ?)" isOwner :: (TeamId, UserId, Maybe Permissions) -> Bool -isOwner (_, _, Just p) = SetBilling `Set.member` view self p +isOwner (_, _, Just p) = SetBilling `Set.member` p.self isOwner _ = False diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 02994a77a90..df3015be471 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1256,8 +1256,8 @@ ensureNonBindingTeam tid = do ensureNotElevated :: (Member (ErrorS 'InvalidPermissions) r) => Permissions -> TeamMember -> Sem r () ensureNotElevated targetPermissions member = unless - ( (targetPermissions ^. self) - `Set.isSubsetOf` (member ^. permissions . copy) + ( targetPermissions.self + `Set.isSubsetOf` (member ^. permissions).copy ) $ throwS @'InvalidPermissions diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index ef5a1b96b5f..484c769ab0c 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -326,7 +326,7 @@ updateTeamMember oldPerms tid uid newPerms = do addPrepQuery Cql.updatePermissions (newPerms, tid, uid) -- update billing_team_member table - let permDiff = Set.difference `on` view self + let permDiff = Set.difference `on` self acquiredPerms = newPerms `permDiff` oldPerms lostPerms = oldPerms `permDiff` newPerms From 7d0d0c7bf9b130a6e11ecf46d80133b647937419 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 12:00:40 +0200 Subject: [PATCH 37/48] Update user search index on team changes. --- integration/test/Test/Teams.hs | 8 +++++ .../IndexedUserStore/Bulk/ElasticSearch.hs | 7 +++-- .../src/Wire/UserStore/Cassandra.hs | 29 ++++++++++--------- .../src/Wire/UserStore/IndexUser.hs | 15 ++++++---- .../src/Wire/UserSubsystem/Interpreter.hs | 2 +- .../unit/Wire/MockInterpreters/UserStore.hs | 2 +- services/brig/src/Brig/API/User.hs | 3 +- services/brig/src/Brig/Team/API.hs | 2 ++ 8 files changed, 44 insertions(+), 24 deletions(-) diff --git a/integration/test/Test/Teams.hs b/integration/test/Test/Teams.hs index e3394fa769c..c54a7b18b46 100644 --- a/integration/test/Test/Teams.hs +++ b/integration/test/Test/Teams.hs @@ -49,31 +49,37 @@ testInvitePersonalUserToTeam = do bindResponse (listInvitations owner tid) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "invitations" `shouldMatch` ([] :: [()]) + ownerId <- owner %. "id" & asString setTeamFeatureStatus domain tid "exposeInvitationURLsToTeamAdmin" "enabled" >>= assertSuccess user <- createUser domain def >>= getJSON 201 uid <- user %. "id" >>= asString email <- user %. "email" >>= asString + inv <- postInvitation owner (PostInvitation (Just email) Nothing) >>= getJSON 201 checkListInvitations owner tid email code <- getInvitationCode owner inv >>= getJSON 200 >>= (%. "code") & asString inv %. "url" & asString >>= assertUrlContainsCode code acceptTeamInvitation user code Nothing >>= assertStatus 400 acceptTeamInvitation user code (Just "wrong-password") >>= assertStatus 403 + void $ withWebSockets [user] $ \wss -> do acceptTeamInvitation user code (Just defPassword) >>= assertSuccess for wss $ \ws -> do n <- awaitMatch isUserUpdatedNotif ws n %. "payload.0.user.team" `shouldMatch` tid + bindResponse (getSelf user) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "team" `shouldMatch` tid + -- a team member can now find the former personal user in the team bindResponse (getTeamMembers tm tid) $ \resp -> do resp.status `shouldMatchInt` 200 members <- resp.json %. "members" >>= asList ids <- for members ((%. "user") >=> asString) ids `shouldContain` [uid] + -- the former personal user can now see other team members bindResponse (getTeamMembers user tid) $ \resp -> do resp.status `shouldMatchInt` 200 @@ -82,12 +88,14 @@ testInvitePersonalUserToTeam = do tmId <- tm %. "id" & asString ids `shouldContain` [ownerId] ids `shouldContain` [tmId] + -- the former personal user can now search for the owner bindResponse (searchContacts user (owner %. "name") domain) $ \resp -> do resp.status `shouldMatchInt` 200 documents <- resp.json %. "documents" >>= asList ids <- for documents ((%. "id") >=> asString) ids `shouldContain` [ownerId] + refreshIndex domain -- a team member can now search for the former personal user bindResponse (searchContacts tm (user %. "name") domain) $ \resp -> do diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index 64d36d0d131..26ccca02987 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs @@ -88,9 +88,12 @@ syncAllUsersWithVersion mkVersion = mkUserDocs :: ConduitT [IndexUser] [(ES.DocId, UserDoc, ES.VersionControl)] (Sem r) () mkUserDocs = Conduit.mapM $ \page -> do - visMap <- fmap Map.fromList . unsafePooledForConcurrentlyN 16 (Set.fromList $ mapMaybe (.teamId) page) $ \t -> + let teamIds = + Set.fromList $ + mapMaybe (fmap value . ((.teamId))) page + visMap <- fmap Map.fromList . unsafePooledForConcurrentlyN 16 teamIds $ \t -> (t,) <$> teamSearchVisibilityInbound t - let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ flip Map.lookup visMap =<< indexUser.teamId + let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ (flip Map.lookup visMap . value =<< indexUser.teamId) mkUserDoc indexUser = indexUserToDoc (vis indexUser) indexUser mkDocVersion = mkVersion . ES.ExternalDocVersion . docVersion . indexUserToVersion pure $ map (\u -> (userIdToDocId u.userId, mkUserDoc u, mkDocVersion u)) page diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 1e21902aba2..ee7f51bab8c 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -53,19 +53,22 @@ getIndexUserPaginatedImpl pageSize mPagingState = getIndexUserBaseQuery :: LText getIndexUserBaseQuery = - "SELECT \ - \id, team, \ - \name, writetime(name), \ - \status, writetime(status), \ - \handle, writetime(handle), \ - \email, writetime(email), \ - \accent_id, writetime(accent_id), \ - \activated, writetime(activated), \ - \service, writetime(service), \ - \managed_by, writetime(managed_by), \ - \sso_id, writetime(sso_id), \ - \email_unvalidated, writetime(email_unvalidated) \ - \FROM user" + [sql| + SELECT + id, + team, writetime(team), + name, writetime(name), + status, writetime(status), + handle, writetime(handle), + email, writetime(email), + accent_id, writetime(accent_id), + activated, writetime(activated), + service, writetime(service), + managed_by, writetime(managed_by), + sso_id, writetime(sso_id), + email_unvalidated, writetime(email_unvalidated) + FROM user + |] updateUserImpl :: UserId -> StoredUserUpdate -> Client () updateUserImpl uid update = diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index 523e9d8f767..2334260f447 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -25,7 +25,7 @@ data WithWritetime a = WithWriteTime {value :: a, writetime :: Writetime a} data IndexUser = IndexUser { userId :: UserId, - teamId :: Maybe TeamId, + teamId :: Maybe (WithWritetime TeamId), name :: WithWritetime Name, accountStatus :: Maybe (WithWritetime AccountStatus), handle :: Maybe (WithWritetime Handle), @@ -42,7 +42,7 @@ data IndexUser = IndexUser type instance TupleType IndexUser = ( UserId, - Maybe TeamId, + Maybe TeamId, Maybe (Writetime TeamId), Name, Writetime Name, Maybe AccountStatus, Maybe (Writetime AccountStatus), Maybe Handle, Maybe (Writetime Handle), @@ -57,7 +57,8 @@ type instance instance Record IndexUser where asTuple (IndexUser {..}) = - ( userId, teamId, + ( userId, + value <$> teamId, writetime <$> teamId, name.value, name.writetime, value <$> accountStatus, writetime <$> accountStatus, value <$> handle, writetime <$> handle, @@ -71,7 +72,8 @@ instance Record IndexUser where ) asRecord - ( u, mteam, + ( u, + mTeam, tTeam, name, tName, status, tStatus, handle, tHandle, @@ -84,7 +86,7 @@ instance Record IndexUser where emailUnvalidated, tEmailUnvalidated ) = IndexUser { userId = u, - teamId = mteam, + teamId = WithWriteTime <$> mTeam <*> tTeam, name = WithWriteTime name tName, accountStatus = WithWriteTime <$> status <*> tStatus, handle = WithWriteTime <$> handle <*> tHandle, @@ -102,6 +104,7 @@ indexUserToVersion :: IndexUser -> IndexVersion indexUserToVersion IndexUser {..} = mkIndexVersion [ const () <$$> Just name.writetime, + const () <$$> fmap writetime teamId, const () <$$> fmap writetime accountStatus, const () <$$> fmap writetime handle, const () <$$> fmap writetime email, @@ -133,7 +136,7 @@ indexUserToDoc searchVisInbound IndexUser {..} = udHandle = value <$> handle, udNormalized = Just $ normalized name.value.fromName, udName = Just name.value, - udTeam = teamId, + udTeam = value <$> teamId, udId = userId } else -- We insert a tombstone-style user here, as it's easier than diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 8e087904d37..aff11d4d663 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -561,7 +561,7 @@ syncUserIndex uid = vis <- maybe (pure defaultSearchVisibilityInbound) - teamSearchVisibilityInbound + (teamSearchVisibilityInbound . value) indexUser.teamId let userDoc = indexUserToDoc vis indexUser version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserToVersion indexUser diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 68b5d373a73..fd8eddbe06f 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -72,7 +72,7 @@ storedUserToIndexUser storedUser = let withDefaultTime x = WithWriteTime x $ Writetime $ UTCTime (YearDay 0 1) 0 in IndexUser { userId = storedUser.id, - teamId = storedUser.teamId, + teamId = withDefaultTime <$> storedUser.teamId, name = withDefaultTime storedUser.name, accountStatus = withDefaultTime <$> storedUser.status, handle = withDefaultTime <$> storedUser.handle, diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 36b464108d0..17331d18ce1 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -398,7 +398,8 @@ createUser new = do unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do - wrapClient $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) + -- ('insertAccount' sets column activated to False; here it is set to True.) + wrapClient $ activateUser uid ident void $ onActivated (AccountActivated account) liftSem do Log.info $ diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 4ef9c9e275d..158f35220ce 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -95,6 +95,7 @@ import Wire.PasswordStore import Wire.Sem.Concurrency import Wire.UserKeyStore import Wire.UserSubsystem +import Wire.UserSubsystem qualified as User import Wire.UserSubsystem.Error servantAPI :: @@ -592,6 +593,7 @@ acceptTeamInvitationByPersonalUser luid req = do lift $ do wrapClient $ User.updateUserTeam uid tid liftSem $ Store.deleteInvitation inv.teamId inv.invitationId + liftSem $ User.internalUpdateSearchIndex uid liftSem $ Events.generateUserEvent uid Nothing (teamUpdated uid tid) where checkPassword = do From 99ab272de7eef586dfa720f0fa22aea8072138d5 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 13:58:53 +0200 Subject: [PATCH 38/48] Pass casClient instead of embed. --- .../src/Wire/FederationConfigStore/Cassandra.hs | 13 ++++++------- services/brig/src/Brig/CanonicalInterpreter.hs | 2 +- services/brig/src/Brig/Index/Eval.hs | 2 +- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/FederationConfigStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/FederationConfigStore/Cassandra.hs index 1ccd7435d60..2038fc697ed 100644 --- a/libs/wire-subsystems/src/Wire/FederationConfigStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/FederationConfigStore/Cassandra.hs @@ -33,6 +33,7 @@ import Data.Qualified import Database.CQL.Protocol (SerialConsistency (LocalSerialConsistency), serialConsistency) import Imports import Polysemy +import Polysemy.Embed import Wire.API.Routes.FederationDomainConfig import Wire.API.User.Search import Wire.FederationConfigStore @@ -44,20 +45,18 @@ import Wire.FederationConfigStore -- If a domain is configured in the config file, it is not allowed to update it in the database. -- If a domain is configured in the config file, it is not allowed to add a team restriction to it in the database. -- In the future the config file will be removed and the database will be the only source of truth. --- --- TODO: Just take a ClientState instead of (Embed m) interpretFederationDomainConfig :: - forall m r a. - ( MonadClient m, - Member (Embed m) r + forall r a. + ( Member (Embed IO) r ) => + ClientState -> Maybe FederationStrategy -> Map Domain FederationDomainConfig -> Sem (FederationConfigStore ': r) a -> Sem r a -interpretFederationDomainConfig mFedStrategy fedCfgs = +interpretFederationDomainConfig casClient mFedStrategy fedCfgs = interpret $ - embed @m . \case + runEmbedded (runClient casClient) . embed . \case GetFederationConfig d -> getFederationConfig' fedCfgs d GetFederationConfigs -> getFederationConfigs' mFedStrategy fedCfgs AddFederationConfig cnf -> addFederationConfig' fedCfgs cnf diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index e7946c2398e..936c1c7dd95 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -218,7 +218,7 @@ runBrigToIO e (AppT ma) = do . interpretJwtTools . interpretPublicKeyBundle . interpretJwk - . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) + . interpretFederationDomainConfig (e ^. casClient) (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) . runGundeckAPIAccess (e ^. gundeckEndpoint) . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig (e ^. App.requestId)) . runInputConst (teamTemplatesNoLocale e) diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 3d1f0c15c22..64dd9ebca59 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -130,7 +130,7 @@ runSem esConn cas galleyEndpoint logger action = do . throwErrorToIOFinal @ParseException . interpretGalleyAPIAccessToRpc mempty galleyEndpoint . runEmbedded (runClient casClient) - . interpretFederationDomainConfig Nothing mempty + . interpretFederationDomainConfig casClient Nothing mempty . raiseUnder @(Embed Client) . throwErrorToIOFinal @MigrationException . interpretIndexedUserMigrationStoreES bhEnv From 8c73d31a0e7e8bc5fcfe2bce2717f6843d4ff8a6 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 14:22:17 +0200 Subject: [PATCH 39/48] Error for searcher doesn't exist. --- libs/wire-api/src/Wire/API/Error/Brig.hs | 3 +++ libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs | 2 ++ libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 2 +- 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index 16efe68b803..e34fc3ae61f 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -40,6 +40,7 @@ data BrigError | NotConnected | InvalidTransition | NoIdentity + | NoUser | HandleExists | InvalidHandle | HandleNotFound @@ -170,6 +171,8 @@ type instance MapError 'InvalidTransition = 'StaticError 403 "bad-conn-update" " type instance MapError 'NoIdentity = 'StaticError 403 "no-identity" "The user has no verified email" +type instance MapError 'NoUser = 'StaticError 403 "no-user" "The user does not exist" + type instance MapError 'HandleExists = 'StaticError 409 "handle-exists" "The given handle is already taken" type instance MapError 'InvalidHandle = 'StaticError 400 "invalid-handle" "The given handle is invalid (less than 2 or more than 256 characters; chars not in \"a-z0-9_.-\"; or on the blocklist)" diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index 22b1a8e44ec..f1804b06de8 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -13,6 +13,7 @@ data UserSubsystemError | UserSubsystemHandleManagedByScim | UserSubsystemLocaleManagedByScim | UserSubsystemNoIdentity + | UserSubsystemNoUser | UserSubsystemHandleExists | UserSubsystemInvalidHandle | UserSubsystemProfileNotFound @@ -26,6 +27,7 @@ userSubsystemErrorToHttpError = UserSubsystemDisplayNameManagedByScim -> errorToWai @E.NameManagedByScim UserSubsystemLocaleManagedByScim -> errorToWai @E.LocaleManagedByScim UserSubsystemNoIdentity -> errorToWai @E.NoIdentity + UserSubsystemNoUser -> errorToWai @E.NoUser UserSubsystemHandleExists -> errorToWai @E.HandleExists UserSubsystemInvalidHandle -> errorToWai @E.InvalidHandle UserSubsystemHandleManagedByScim -> errorToWai @E.HandleManagedByScim diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index aff11d4d663..ec07586c9de 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -594,7 +594,7 @@ searchUsersImpl :: Maybe (Range 1 500 Int32) -> Sem r (SearchResult Contact) searchUsersImpl searcherId searchTerm maybeDomain maybeMaxResults = do - storedSearcher <- fromMaybe (error "TODO: searcher is not real") <$> UserStore.getUser (tUnqualified searcherId) + storedSearcher <- note UserSubsystemNoUser =<< UserStore.getUser (tUnqualified searcherId) for_ storedSearcher.teamId $ \tid -> ensurePermissions (tUnqualified searcherId) tid [SearchContacts] let localDomain = tDomain searcherId queryDomain = fromMaybe localDomain maybeDomain From 1446cdb75ebbd9ca3392aae95f9201218b5d32bb Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 15:04:02 +0200 Subject: [PATCH 40/48] Removed TODO, out of scope. --- services/brig/src/Brig/User/Search/SearchIndex.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index cde45a8a362..f45006c8387 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -38,7 +38,6 @@ import Imports hiding (log, searchable) import Wire.API.User (ColourId (..), Name (fromName)) import Wire.API.User.Search import Wire.IndexedUserStore (IndexedUserStoreError (..)) --- TODO: Move all this code to the interpreter instead of importing it? import Wire.IndexedUserStore.ElasticSearch (mappingName) import Wire.UserSearch.Types import Wire.UserStore.IndexUser (normalized) From d8bac4223da617fe57efdf6881ea344f7a17f502 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 15:05:07 +0200 Subject: [PATCH 41/48] Upgraded TODO to FUTUREWORK. --- libs/wire-subsystems/src/Wire/FederationConfigStore.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/FederationConfigStore.hs b/libs/wire-subsystems/src/Wire/FederationConfigStore.hs index 8b9bee0f9bf..ead299d37c0 100644 --- a/libs/wire-subsystems/src/Wire/FederationConfigStore.hs +++ b/libs/wire-subsystems/src/Wire/FederationConfigStore.hs @@ -24,8 +24,8 @@ data AddFederationRemoteTeamResult | AddFederationRemoteTeamDomainNotFound | AddFederationRemoteTeamRestrictionAllowAll --- TODO: This store effect is more than just a store, we should break it up in --- business logic and store +-- FUTUREWORK: This store effect is more than just a store, +-- we should break it up in business logic and store data FederationConfigStore m a where GetFederationConfig :: Domain -> FederationConfigStore m (Maybe FederationDomainConfig) GetFederationConfigs :: FederationConfigStore m FederationDomainConfigs From 1861511191832d76ded8ab84ce69f4ad9a8d17dd Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 17 Sep 2024 15:47:01 +0200 Subject: [PATCH 42/48] Added changelogs. --- changelog.d/5-internal/WPB-888-2 | 1 + changelog.d/5-internal/WPB-8888 | 1 + libs/wire-api/src/Wire/API/Team/Permission.hs | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 changelog.d/5-internal/WPB-888-2 create mode 100644 changelog.d/5-internal/WPB-8888 diff --git a/changelog.d/5-internal/WPB-888-2 b/changelog.d/5-internal/WPB-888-2 new file mode 100644 index 00000000000..b898071cea8 --- /dev/null +++ b/changelog.d/5-internal/WPB-888-2 @@ -0,0 +1 @@ +Removed `indexReindex` and `indexReindexIfSameOrNewer` from internal Brig/SearchIndex. diff --git a/changelog.d/5-internal/WPB-8888 b/changelog.d/5-internal/WPB-8888 new file mode 100644 index 00000000000..f5d3655308a --- /dev/null +++ b/changelog.d/5-internal/WPB-8888 @@ -0,0 +1 @@ +Introduced ElasticSearch effects related to user search. diff --git a/libs/wire-api/src/Wire/API/Team/Permission.hs b/libs/wire-api/src/Wire/API/Team/Permission.hs index f8d5ba61fa7..26ddd8865ba 100644 --- a/libs/wire-api/src/Wire/API/Team/Permission.hs +++ b/libs/wire-api/src/Wire/API/Team/Permission.hs @@ -201,7 +201,7 @@ instance Cql.Cql Permissions where toCql p = let f = Cql.CqlBigInt . fromIntegral . permsToInt - in Cql.CqlUdt [("self", f (p.self)), ("copy", f (p.copy))] + in Cql.CqlUdt [("self", f p.self), ("copy", f p.copy)] fromCql (Cql.CqlUdt p) = do let f = intToPerms . fromIntegral :: Int64 -> Set.Set Perm From 69ce200039967e32badb378348d01f7bc8ec5db0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 18 Sep 2024 10:47:28 +0200 Subject: [PATCH 43/48] UserSubsystem: simplify folding over a domain --- .../src/Wire/UserSubsystem/Interpreter.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index ec07586c9de..e496028fac8 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -596,11 +596,12 @@ searchUsersImpl :: searchUsersImpl searcherId searchTerm maybeDomain maybeMaxResults = do storedSearcher <- note UserSubsystemNoUser =<< UserStore.getUser (tUnqualified searcherId) for_ storedSearcher.teamId $ \tid -> ensurePermissions (tUnqualified searcherId) tid [SearchContacts] - let localDomain = tDomain searcherId - queryDomain = fromMaybe localDomain maybeDomain - if queryDomain == localDomain - then searchLocally (qualifyAs searcherId storedSearcher) searchTerm maybeMaxResults - else searchRemotely queryDomain storedSearcher.teamId searchTerm + let qDomain = Qualified () (fromMaybe (tDomain searcherId) maybeDomain) + foldQualified + searcherId + (\ldom -> searchLocally (qualifyAs ldom storedSearcher) searchTerm maybeMaxResults) + (\rdom -> searchRemotely rdom storedSearcher.teamId searchTerm) + qDomain searchLocally :: forall r. @@ -701,11 +702,12 @@ searchRemotely :: Member TinyLog r, Member (Error FederationError) r ) => - Domain -> + Remote x -> Maybe TeamId -> Text -> Sem r (SearchResult Contact) -searchRemotely domain mTid searchTerm = do +searchRemotely rDom mTid searchTerm = do + let domain = tDomain rDom Log.info $ Log.msg (Log.val "searchRemotely") . Log.field "domain" (show domain) @@ -718,7 +720,7 @@ searchRemotely domain mTid searchTerm = do Nothing -> Just [] searchResponse <- - runFederated (toRemoteUnsafe domain ()) $ + runFederated rDom $ fedClient @'Brig @"search-users" (FedBrig.SearchRequest searchTerm mTid onlyInTeams) let contacts = searchResponse.contacts let count = length contacts From 7404df1cf6a882ddaf8083bf5df73bc4056c056d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 18 Sep 2024 13:45:36 +0200 Subject: [PATCH 44/48] Bubble up liftSem'ing --- services/brig/src/Brig/Team/API.hs | 46 ++++++++++++++++-------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 158f35220ce..bdb0e911b45 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -114,11 +114,14 @@ servantAPI :: ServerT TeamsAPI (Handler r) servantAPI = Named @"send-team-invitation" createInvitation - :<|> Named @"get-team-invitations" listInvitations - :<|> Named @"get-team-invitation" getInvitation - :<|> Named @"delete-team-invitation" deleteInvitation + :<|> Named @"get-team-invitations" + (\u t inv s -> lift . liftSem $ listInvitations u t inv s) + :<|> Named @"get-team-invitation" + (\u t inv -> lift . liftSem $ getInvitation u t inv) + :<|> Named @"delete-team-invitation" + (\u t inv -> lift . liftSem $ deleteInvitation u t inv) :<|> Named @"get-team-invitation-info" getInvitationByCode - :<|> Named @"head-team-invitations" headInvitationByEmail + :<|> Named @"head-team-invitations" (lift . liftSem . headInvitationByEmail) :<|> Named @"get-team-size" teamSizePublic :<|> Named @"accept-team-invitation" acceptTeamInvitationByPersonalUser @@ -332,8 +335,8 @@ deleteInvitation :: UserId -> TeamId -> InvitationId -> - (Handler r) () -deleteInvitation uid tid iid = (lift . liftSem) do + Sem r () +deleteInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] Store.deleteInvitation tid iid @@ -351,8 +354,8 @@ listInvitations :: TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> - (Handler r) Public.InvitationList -listInvitations uid tid startingId mSize = (lift . liftSem) do + Sem r Public.InvitationList +listInvitations uid tid startingId mSize = do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid let toInvitations is = mapM (toInvitationHack showInvitationUrl) is @@ -462,8 +465,8 @@ getInvitation :: UserId -> TeamId -> InvitationId -> - (Handler r) (Maybe Public.Invitation) -getInvitation uid tid iid = (lift . liftSem) do + Sem r (Maybe Public.Invitation) +getInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] invitationM <- Store.lookupInvitation tid iid @@ -482,18 +485,19 @@ getInvitationByCode c = do inv <- lift . liftSem $ Store.lookupInvitationByCode c maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv -headInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult +headInvitationByEmail :: + (Member InvitationCodeStore r, Member TinyLog r) => + EmailAddress -> + Sem r Public.HeadInvitationByEmailResult headInvitationByEmail email = - lift $ - liftSem $ - Store.lookupInvitationCodesByEmail email >>= \case - [] -> pure Public.InvitationByEmailNotFound - [_code] -> pure Public.InvitationByEmail - (_ : _ : _) -> do - Log.info $ - Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") - . Log.field "email" (show email) - pure Public.InvitationByEmailMoreThanOne + Store.lookupInvitationCodesByEmail email >>= \case + [] -> pure Public.InvitationByEmailNotFound + [_code] -> pure Public.InvitationByEmail + (_ : _ : _) -> do + Log.info $ + Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") + . Log.field "email" (show email) + pure Public.InvitationByEmailMoreThanOne -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and From 4b39d28f8d7474a5af2f8f3c7086a355197bca52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 18 Sep 2024 14:19:16 +0200 Subject: [PATCH 45/48] Remove commented out code --- libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index e496028fac8..8ab93c3649f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -675,10 +675,6 @@ searchLocally searcher searchTerm maybeMaxResults = do isContactVisible = (config.searchSameTeamOnly && (tUnqualified searcher).teamId == storedUser.teamId) || (not config.searchSameTeamOnly) - -- case teamSerachInfo of - -- AllUsers -> True - -- NoTeam -> isNothing (storedUser.teamId) - -- TeamOnly tid -> storedUser.teamId == Just tid if isContactVisible then pure contact else MaybeT $ pure Nothing From d479ed6438cbe7412d887cc5046d911f12b322b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 18 Sep 2024 14:23:02 +0200 Subject: [PATCH 46/48] Error messages for mocks/uninterpreted actions --- .../MockInterpreters/FederationConfigStore.hs | 15 ++++++++++----- .../test/unit/Wire/MockInterpreters/UserStore.hs | 3 ++- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs index 647a2139dc3..57a9bf5566e 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/FederationConfigStore.hs @@ -18,11 +18,16 @@ inMemoryFederationConfigStoreInterpreter = AddFederationConfig newCfg -> do modify $ (newCfg :) . deleteBy (\a b -> a.domain == b.domain) newCfg pure AddFederationRemoteSuccess - UpdateFederationConfig cfg -> undefined cfg - AddFederationRemoteTeam domain team -> undefined domain team - RemoveFederationRemoteTeam domain team -> undefined domain team - GetFederationRemoteTeams domain -> undefined domain - BackendFederatesWith remoteMaybeTeam -> undefined remoteMaybeTeam + UpdateFederationConfig _ -> + error "UpdateFederationConfig not implemented in inMemoryFederationConfigStoreInterpreter" + AddFederationRemoteTeam _ _ -> + error "AddFederationRemoteTeam not implemented in inMemoryFederationConfigStoreInterpreter" + RemoveFederationRemoteTeam _ _ -> + error "RemoveFederationRemoteTeam not implemented in inMemoryFederationConfigStoreInterpreter" + GetFederationRemoteTeams _ -> + error "GetFederationRemoteTeams not implemented in inMemoryFederationConfigStoreInterpreter" + BackendFederatesWith _ -> + error "BackendFederatesWith not implemented in inMemoryFederationConfigStoreInterpreter" runFederationConfigStoreInMemory :: InterpreterFor FederationConfigStore r runFederationConfigStoreInMemory = diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index fd8eddbe06f..a1e0e5d96e1 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -37,7 +37,8 @@ inMemoryUserStoreInterpreter = interpret $ \case else u GetIndexUser uid -> gets $ fmap storedUserToIndexUser . find (\user -> user.id == uid) - GetIndexUsersPaginated _pageSize _pagingState -> undefined + GetIndexUsersPaginated _pageSize _pagingState -> + error "GetIndexUsersPaginated not implemented in inMemoryUserStoreInterpreter" UpdateUserHandleEither uid hUpdate -> runError $ modifyLocalUsers (traverse doUpdate) where doUpdate :: StoredUser -> Sem (Error StoredUserUpdateError : r) StoredUser From 567a8d37a5c2c892ad00ce91d1f1bc4ee4691aaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 18 Sep 2024 17:16:26 +0200 Subject: [PATCH 47/48] Remove a UserSubsystemError --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 7 ++++- .../src/Wire/UserSubsystem/Error.hs | 2 -- .../src/Wire/UserSubsystem/Interpreter.hs | 29 ++++++++++++------- 3 files changed, 25 insertions(+), 13 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index f4106f116e0..95cfcc4ad6e 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -125,7 +125,12 @@ data UserSubsystem m a where -- | Add an email to the block list. BlockListInsert :: EmailAddress -> UserSubsystem m () UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSubsystem m () - SearchUsers :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSubsystem m (SearchResult Contact) + SearchUsers :: + Local UserId -> + Text -> + Maybe Domain -> + Maybe (Range 1 500 Int32) -> + UserSubsystem m (SearchResult Contact) BrowseTeam :: UserId -> BrowseTeamFilters -> diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index f1804b06de8..22b1a8e44ec 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -13,7 +13,6 @@ data UserSubsystemError | UserSubsystemHandleManagedByScim | UserSubsystemLocaleManagedByScim | UserSubsystemNoIdentity - | UserSubsystemNoUser | UserSubsystemHandleExists | UserSubsystemInvalidHandle | UserSubsystemProfileNotFound @@ -27,7 +26,6 @@ userSubsystemErrorToHttpError = UserSubsystemDisplayNameManagedByScim -> errorToWai @E.NameManagedByScim UserSubsystemLocaleManagedByScim -> errorToWai @E.LocaleManagedByScim UserSubsystemNoIdentity -> errorToWai @E.NoIdentity - UserSubsystemNoUser -> errorToWai @E.NoUser UserSubsystemHandleExists -> errorToWai @E.HandleExists UserSubsystemInvalidHandle -> errorToWai @E.InvalidHandle UserSubsystemHandleManagedByScim -> errorToWai @E.HandleManagedByScim diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 8ab93c3649f..769be28ee74 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -594,13 +594,17 @@ searchUsersImpl :: Maybe (Range 1 500 Int32) -> Sem r (SearchResult Contact) searchUsersImpl searcherId searchTerm maybeDomain maybeMaxResults = do - storedSearcher <- note UserSubsystemNoUser =<< UserStore.getUser (tUnqualified searcherId) - for_ storedSearcher.teamId $ \tid -> ensurePermissions (tUnqualified searcherId) tid [SearchContacts] + let searcher = tUnqualified searcherId + mSearcherTeamId <- + UserStore.getUser searcher >>= \mTeam -> pure (mTeam >>= (.teamId)) + + for_ mSearcherTeamId $ \tid -> + ensurePermissions searcher tid [SearchContacts] let qDomain = Qualified () (fromMaybe (tDomain searcherId) maybeDomain) foldQualified searcherId - (\ldom -> searchLocally (qualifyAs ldom storedSearcher) searchTerm maybeMaxResults) - (\rdom -> searchRemotely rdom storedSearcher.teamId searchTerm) + (\_ -> searchLocally ((,mSearcherTeamId) <$> searcherId) searchTerm maybeMaxResults) + (\rdom -> searchRemotely rdom mSearcherTeamId searchTerm) qDomain searchLocally :: @@ -610,15 +614,14 @@ searchLocally :: Member IndexedUserStore r, Member (Input UserSubsystemConfig) r ) => - Local StoredUser -> + Local (UserId, Maybe TeamId) -> Text -> Maybe (Range 1 500 Int32) -> Sem r (SearchResult Contact) searchLocally searcher searchTerm maybeMaxResults = do let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults - let searcherTeamId = (tUnqualified searcher).teamId - searcherId = (tUnqualified searcher).id - teamSearchInfo <- mkTeamSearchInfo searcherTeamId + let (searcherId, searcherTeamId) = (fst <$> searcher, snd <$> searcher) + teamSearchInfo <- mkTeamSearchInfo (tUnqualified searcherTeamId) maybeExactHandleMatch <- exactHandleSearch teamSearchInfo @@ -627,7 +630,13 @@ searchLocally searcher searchTerm maybeMaxResults = do esResult <- if esMaxResults > 0 - then IndexedUserStore.searchUsers searcherId searcherTeamId teamSearchInfo searchTerm esMaxResults + then + IndexedUserStore.searchUsers + (tUnqualified searcherId) + (tUnqualified searcherTeamId) + teamSearchInfo + searchTerm + esMaxResults else pure $ SearchResult 0 0 0 [] FullSearch Nothing Nothing -- Prepend results matching exact handle and results from ES. @@ -673,7 +682,7 @@ searchLocally searcher searchTerm maybeMaxResults = do config <- lift input let contact = contactFromStoredUser (tDomain searcher) storedUser isContactVisible = - (config.searchSameTeamOnly && (tUnqualified searcher).teamId == storedUser.teamId) + (config.searchSameTeamOnly && (snd . tUnqualified $ searcher) == storedUser.teamId) || (not config.searchSameTeamOnly) if isContactVisible then pure contact From 01fa1bd3caab27035a21db676193fb644ce559a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 18 Sep 2024 17:34:38 +0200 Subject: [PATCH 48/48] Remove unusued MapError instance --- libs/wire-api/src/Wire/API/Error/Brig.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index e34fc3ae61f..416e5fecaa2 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -171,8 +171,6 @@ type instance MapError 'InvalidTransition = 'StaticError 403 "bad-conn-update" " type instance MapError 'NoIdentity = 'StaticError 403 "no-identity" "The user has no verified email" -type instance MapError 'NoUser = 'StaticError 403 "no-user" "The user does not exist" - type instance MapError 'HandleExists = 'StaticError 409 "handle-exists" "The given handle is already taken" type instance MapError 'InvalidHandle = 'StaticError 400 "invalid-handle" "The given handle is invalid (less than 2 or more than 256 characters; chars not in \"a-z0-9_.-\"; or on the blocklist)"