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..8ab5bfdd401 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,167 @@ 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 + -- idx <- input + 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 + -- localDomain <- viewFederationDomain + let search = (ES.mkSearch (Just q) (Just f)) {ES.size = ES.Size (fromIntegral s)} + mkResult <$> searchInMainIndex cfg search + where + -- 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 + + 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 d00d01a50c9..d991942bbc9 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..f54e4faf2d5 100644 --- a/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSearchSubsystem.hs @@ -11,24 +11,23 @@ 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 +-- | This function exists because there are a lot query params and they cannot +-- all become 'BrowseTeamFilters' automatically browseTeamHandler :: (Member UserSearchSubsystem r) => UserId -> @@ -37,9 +36,9 @@ browseTeamHandler :: Maybe RoleFilter -> Maybe TeamUserSearchSortBy -> Maybe TeamUserSearchSortOrder -> - Maybe (Range 1 500 Int32) -> + Maybe (Range 1 500 Int) -> Maybe PagingState -> - Sem r [TeamContact] + Sem r (SearchResult TeamContact) browseTeamHandler uid tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder mMaxResults mPagingState = do let browseTeamFilters = BrowseTeamFilters tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder browseTeam uid browseTeamFilters mMaxResults mPagingState diff --git a/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSearchSubsystem/Interpreter.hs index 9541a725312..f548d620326 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,10 +13,11 @@ 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 +import Polysemy.Input import Polysemy.TinyLog import Polysemy.TinyLog qualified as Log import Servant.Client.Core (RunClient) @@ -26,6 +29,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 @@ -70,7 +74,8 @@ interpretUserSearchSubsystem config = interpret \case UpdateTeamSearchVisibilityInbound status -> updateTeamSearchVisibilityInboundImpl status SearchUsers luid query mDomain mMaxResults -> searchUsersImpl config luid query mDomain mMaxResults BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> do - browseTeamImpl uid browseTeamFilters mMaxResults mPagingState + let idxName = undefined + runInputConst idxName $ browseTeamImpl uid browseTeamFilters mMaxResults mPagingState interpretUserSearchSubsystemBulk :: ( Member TinyLog r, @@ -209,16 +214,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 +344,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 +403,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/src/Brig/User/Search/TeamUserSearch.hs b/services/brig/src/Brig/User/Search/TeamUserSearch.hs index c071094c6da..c2320d70de7 100644 --- a/services/brig/src/Brig/User/Search/TeamUserSearch.hs +++ b/services/brig/src/Brig/User/Search/TeamUserSearch.hs @@ -91,6 +91,10 @@ teamUserSearch tid mbSearchText mRoleFilter mSortBy mSortOrder (fromRange -> siz searchHasMore = Just $ length hitsPlusOne > length hits } +-- TODO(md): Remove from here as it is not used but in this module's +-- 'teamUserSearch', and that one has been moving to the interpretation of the +-- 'BrowseTeam' action. +-- -- FUTURWORK: Implement role filter (needs galley data) teamUserSearchQuery :: TeamId ->