WPB-20214: Add member searchability

changelog.d/2-features/WPB-20214

@@ -0,0 +1,3 @@
+Add `searchable` field to users, users who have it set to `false` won't be found by the public endpoint.
+Add `POST /users/:uid/searchable` endpoint where team admin can change it for user.
+Add `/teams/:tid/search?searchable=false`, where the query parameter makes it return only non-searchable users.

integration/test/API/Brig.hs

@@ -262,6 +262,11 @@ searchTeamWithSearchTerm user q = searchTeam user [("q", q)]
 searchTeamAll :: (HasCallStack, MakesValue user) => user -> App Response
 searchTeamAll user = searchTeam user [("q", ""), ("size", "100"), ("sortby", "created_at"), ("sortorder", "desc")]
 
+setUserSearchable :: (MakesValue user) => user -> String -> Bool -> App Response
+setUserSearchable self uid searchable = do
+  req <- baseRequest self Brig Versioned $ joinHttpPath ["users", uid, "searchable"]
+  submit "POST" $ addJSON searchable req
+
 getAPIVersion :: (HasCallStack, MakesValue domain) => domain -> App Response
 getAPIVersion domain = do
   req <- baseRequest domain Brig Unversioned $ "/api-version"

integration/test/Test/Search.hs

@@ -12,6 +12,7 @@ import GHC.Stack
 import SetupHelpers
 import Testlib.Assertions
 import Testlib.Prelude
+import qualified Data.Set as Set
 
 --------------------------------------------------------------------------------
 -- LOCAL SEARCH
@@ -358,3 +359,124 @@ testTeamSearchUserIncludesUserGroups = do
       let expectedUgs = fromMaybe [] (lookup uid expected)
       actualUgs <- for ugs asString
       actualUgs `shouldMatchSet` expectedUgs
+
+withFoundDocs ::
+  (MakesValue user, MakesValue searchTerm) =>
+  user ->
+  searchTerm ->
+  ([Value] -> App a) ->
+  App a
+withFoundDocs self term f = do
+  BrigP.searchContacts self term OwnDomain `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    docs <- resp.json %. "documents" >>= asList
+    f docs
+
+testUserSearchable :: App ()
+testUserSearchable = do
+  -- Create team and all users who are part of this test
+  (owner, tid, [u1, u3, u4]) <- createTeam OwnDomain 4
+  admin <- createTeamMember owner def {role = "admin"}
+  let everyone = [owner, u1, admin, u3, u4]
+
+  -- All users are searchable by default
+  assertBool "created users are searchable by default" . and =<< mapM (\u -> u %. "searchable" & asBool) everyone
+
+  -- Setting self to non-searchable won't work -- only admin can do it.
+  u1id <- u1 %. "id" & asString
+  BrigP.setUserSearchable u1 u1id False `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 403
+    resp.json %. "label" `shouldMatch` "insufficient-permissions"
+
+  BrigP.getUser u1 u1 `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    (resp.json %. "searchable") `shouldMatch` True
+
+  -- Team admin can set user to non-searchable.
+  BrigP.setUserSearchable admin u1id False `bindResponse` \resp -> resp.status `shouldMatchInt` 200
+  BrigP.getUser u1 u1 `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    (resp.json %. "searchable") `shouldMatch` False
+
+  -- Team owner can, too.
+  BrigP.setUserSearchable owner u1id True `bindResponse` \resp -> resp.status `shouldMatchInt` 200
+  BrigP.setUserSearchable owner u1id False `bindResponse` \resp -> resp.status `shouldMatchInt` 200
+
+  -- By default created team members are found.
+  u3id <- u3 %. "id" & asString
+  BrigI.refreshIndex OwnDomain
+  withFoundDocs u1 (u3 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "u1 must find u3 as they are searchable by default" $ u3id `elem` foundUids
+
+  -- User set to non-searchable is not found by other team members.
+  u4id <- u4 %. "id" & asString
+  BrigP.setUserSearchable owner u4id False `bindResponse` \resp -> resp.status `shouldMatchInt` 200
+  BrigI.refreshIndex OwnDomain
+  withFoundDocs u1 (u4 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "u1 must not find u4 as they are set non-searchable" $ notElem u4id foundUids
+
+  -- Even admin nor owner won't find non-searchable users via /search/contacts
+  withFoundDocs admin (u4 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "Team admin won't find non-searchable user" $ notElem u4id foundUids
+  withFoundDocs owner (u4 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "Team owner won't find non-searchable user from /search/concatcs" $ notElem u4id foundUids
+
+  -- Exact handle search with HTTP HEAD still works for non-searchable users
+  u4handle <- API.randomHandle
+  bindResponse (BrigP.putHandle u4 u4handle) assertSuccess
+  baseRequest u3 Brig Versioned (joinHttpPath ["handles", u4handle]) >>= \req ->
+    submit "HEAD" req `bindResponse` \resp -> do
+      resp.status `shouldMatchInt` 200 -- (200 means "handle is taken", 404 would be "not found")
+
+  -- Handle for POST /handles still works for non-searchable users
+  u3handle <- API.randomHandle
+  bindResponse (BrigP.putHandle u3 u3handle) assertSuccess
+  baseRequest u1 Brig Versioned (joinHttpPath ["handles"]) <&> addJSONObject ["handles" .= [u4handle, u3handle]] >>= \req ->
+    submit "POST" req `bindResponse` \resp -> do
+      resp.status `shouldMatchInt` 200
+      freeHandles <- resp.json & asList
+      assertBool "POST /handles filters all taken handles, even for regular members" $ null freeHandles
+
+  -- Regular user can't find non-searchable team member by exact handle.
+  withFoundDocs u1 u4handle $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "u1 must not find non-searchable u4 by exact handle" $ notElem u4id foundUids
+
+  -- /teams/:tid/members gets all members, both searchable and non-searchable
+  baseRequest u1 Galley Versioned (joinHttpPath ["teams", tid, "members"]) >>= \req ->
+    submit "GET" req `bindResponse` \resp -> do
+      resp.status `shouldMatchInt` 200
+      docs <- resp.json %. "members" >>= asList
+      foundUids <- mapM (\m -> m %. "user" & asString) docs
+      assertBool "/teams/:tid/members returns searchable and non-searchable users from team" $ all (`elem` foundUids) $ [u1id, u3id, u4id]
+
+  -- /teams/:tid/search?searchable=false gets only non-searchable members
+  baseRequest admin Brig Versioned (joinHttpPath ["teams", tid, "search"]) <&> addQueryParams [("searchable", "false")] >>= \req ->
+    submit "GET" req `bindResponse` \resp -> do
+      resp.status `shouldMatchInt` 200
+      docs <- resp.json %. "documents" >>= asList
+      foundUids <- mapM (\m -> m %. "id" & asString) docs
+      assertBool "/teams/:tid/members?searchable=false returns only non-searchable members" $ Set.fromList foundUids == Set.fromList [u1id, u4id]
+
+  -- /teams/:tid/search and /teams/:tid/search?searchable=true both get all members, searchable and non-searchable
+  noQueryParam <- baseRequest admin Brig Versioned (joinHttpPath ["teams", tid, "search"]) >>= \req ->
+    submit "GET" req `bindResponse` \resp -> do
+      resp.status `shouldMatchInt` 200
+      docs <- resp.json %. "documents" >>= asList
+      mapM (\m -> m %. "id" & asString) docs
+  withQueryParam <- baseRequest admin Brig Versioned (joinHttpPath ["teams", tid, "search"]) <&> addQueryParams [("searchable", "true")] >>= \req ->
+    submit "GET" req `bindResponse` \resp -> do
+      resp.status `shouldMatchInt` 200
+      docs <- resp.json %. "documents" >>= asList
+      mapM (\m -> m %. "id" & asString) docs
+  assertBool "/teams/:tid/search and /teams/:tid/search?searchable=true are equal" $
+    Set.fromList noQueryParam == Set.fromList withQueryParam
+
+  -- All users created as part of this test are in the returned result
+  everyone'sUids <- mapM objId everyone
+  assertBool "All created users as part of this test are in the returned result" $
+    Set.fromList noQueryParam == Set.fromList everyone'sUids

libs/bilge/src/Bilge/Assert.hs

@@ -106,7 +106,7 @@ io <!! aa = do
   m (Response (Maybe Lazy.ByteString)) ->
   Assertions () ->
   m ()
-(!!!) io = void . (<!!) io
+io !!! aa = void (io <!! aa)
 
 infix 4 ===
 

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -161,7 +161,6 @@ instance AsUnion DeleteSelfResponses (Maybe Timeout) where
 type ConnectionUpdateResponses = UpdateResponses "Connection unchanged" "Connection updated" UserConnection
 
 type UserAPI =
-  -- See Note [ephemeral user sideeffect]
   Named
     "get-user-unqualified"
     ( Summary "Get a user by UserId"
@@ -171,16 +170,14 @@ type UserAPI =
         :> CaptureUserId "uid"
         :> GetUserVerb
     )
-    :<|>
-    -- See Note [ephemeral user sideeffect]
-    Named
-      "get-user-qualified"
-      ( Summary "Get a user by Domain and UserId"
-          :> ZLocalUser
-          :> "users"
-          :> QualifiedCaptureUserId "uid"
-          :> GetUserVerb
-      )
+    :<|> Named
+           "get-user-qualified"
+           ( Summary "Get a user by Domain and UserId"
+               :> ZLocalUser
+               :> "users"
+               :> QualifiedCaptureUserId "uid"
+               :> GetUserVerb
+           )
     :<|> Named
            "update-user-email"
            ( Summary "Resend email address validation email."
@@ -224,19 +221,17 @@ type UserAPI =
                      ]
                     (Maybe UserProfile)
            )
-    :<|>
-    -- See Note [ephemeral user sideeffect]
-    Named
-      "list-users-by-unqualified-ids-or-handles"
-      ( Summary "List users (deprecated)"
-          :> Until 'V2
-          :> Description "The 'ids' and 'handles' parameters are mutually exclusive."
-          :> ZUser
-          :> "users"
-          :> QueryParam' [Optional, Strict, Description "User IDs of users to fetch"] "ids" (CommaSeparatedList UserId)
-          :> QueryParam' [Optional, Strict, Description "Handles of users to fetch, min 1 and max 4 (the check for handles is rather expensive)"] "handles" (Range 1 4 (CommaSeparatedList Handle))
-          :> Get '[JSON] [UserProfile]
-      )
+    :<|> Named
+           "list-users-by-unqualified-ids-or-handles"
+           ( Summary "List users (deprecated)"
+               :> Until 'V2
+               :> Description "The 'ids' and 'handles' parameters are mutually exclusive."
+               :> ZUser
+               :> "users"
+               :> QueryParam' [Optional, Strict, Description "User IDs of users to fetch"] "ids" (CommaSeparatedList UserId)
+               :> QueryParam' [Optional, Strict, Description "Handles of users to fetch, min 1 and max 4 (the check for handles is rather expensive)"] "handles" (Range 1 4 (CommaSeparatedList Handle))
+               :> Get '[JSON] [UserProfile]
+           )
     :<|> Named
            "list-users-by-ids-or-handles"
            ( Summary "List users"
@@ -247,18 +242,16 @@ type UserAPI =
                :> ReqBody '[JSON] ListUsersQuery
                :> Post '[JSON] ListUsersById
            )
-    :<|>
-    -- See Note [ephemeral user sideeffect]
-    Named
-      "list-users-by-ids-or-handles@V3"
-      ( Summary "List users"
-          :> Description "The 'qualified_ids' and 'qualified_handles' parameters are mutually exclusive."
-          :> ZUser
-          :> Until 'V4
-          :> "list-users"
-          :> ReqBody '[JSON] ListUsersQuery
-          :> Post '[JSON] [UserProfile]
-      )
+    :<|> Named
+           "list-users-by-ids-or-handles@V3"
+           ( Summary "List users"
+               :> Description "The 'qualified_ids' and 'qualified_handles' parameters are mutually exclusive."
+               :> ZUser
+               :> Until 'V4
+               :> "list-users"
+               :> ReqBody '[JSON] ListUsersQuery
+               :> Post '[JSON] [UserProfile]
+           )
     :<|> Named
            "send-verification-code"
            ( Summary "Send a verification code to a given email address."
@@ -294,6 +287,17 @@ type UserAPI =
                     '[JSON]
                     (Respond 200 "Protocols supported by the user" (Set BaseProtocolTag))
            )
+    :<|> Named
+           "set-user-searchable"
+           ( Summary "Set user's visibility in search"
+               :> From 'V12
+               :> ZLocalUser
+               :> "users"
+               :> CaptureUserId "uid"
+               :> ReqBody '[JSON] Bool
+               :> "searchable"
+               :> Post '[JSON] ()
+           )
 
 type LastSeenNameDesc = Description "`name` of the last seen user group, used to get the next page when sorting by name."
 
@@ -1735,6 +1739,13 @@ type SearchAPI =
              ]
              "email"
              EmailVerificationFilter
+        :> QueryParam'
+             [ Optional,
+               Strict,
+               Description "Optional, return only non-searchable members when false."
+             ]
+             "searchable"
+             Bool
         :> MultiVerb
              'GET
              '[JSON]

libs/wire-api/src/Wire/API/Team/Member.hs

@@ -483,6 +483,7 @@ data HiddenPerm
   | CreateApp
   | ManageApps
   | RemoveTeamCollaborator
+  | SetMemberSearchable
   deriving (Eq, Ord, Show)
 
 -- | See Note [hidden team roles]
@@ -570,7 +571,8 @@ roleHiddenPermissions role = HiddenPermissions p p
             NewTeamCollaborator,
             CreateApp,
             ManageApps,
-            RemoveTeamCollaborator
+            RemoveTeamCollaborator,
+            SetMemberSearchable
           ]
     roleHiddenPerms RoleMember =
       (roleHiddenPerms RoleExternalPartner <>) $
@@ -654,7 +656,7 @@ makeLenses ''TeamMemberList'
 makeLenses ''NewTeamMember'
 makeLenses ''TeamMemberDeleteData
 
-userId :: Lens' TeamMember UserId
+userId :: Lens' (TeamMember' tag) UserId
 userId = newTeamMember . nUserId
 
 permissions :: Lens (TeamMember' tag1) (TeamMember' tag2) (PermissionType tag1) (PermissionType tag2)

libs/wire-api/src/Wire/API/Team/Permission.hs

@@ -128,6 +128,9 @@ serviceWhitelistPermissions =
 -- Perm
 
 -- | Team-level permission.  Analog to conversation-level 'Action'.
+--
+-- If you ever think about adding a new permission flag, read Note
+-- [team roles] first.
 data Perm
   = CreateConversation
   | -- NOTE: This may get overruled by conv level checks in case those are more restrictive
@@ -153,8 +156,6 @@ data Perm
   | DeleteTeam
   -- FUTUREWORK: make the verbs in the roles more consistent
   -- (CRUD vs. Add,Remove vs; Get,Set vs. Create,Delete etc).
-  -- If you ever think about adding a new permission flag,
-  -- read Note [team roles] first.
   deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
   deriving (Arbitrary) via (GenericUniform Perm)
   deriving (FromJSON, ToJSON) via (CustomEncoded Perm)

libs/wire-api/src/Wire/API/User.hs

@@ -509,7 +509,8 @@ data UserProfile = UserProfile
     profileEmail :: Maybe EmailAddress,
     profileLegalholdStatus :: UserLegalHoldStatus,
     profileSupportedProtocols :: Set BaseProtocolTag,
-    profileType :: UserType
+    profileType :: UserType,
+    profileSearchable :: Bool
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform UserProfile)
@@ -549,6 +550,7 @@ instance ToSchema UserProfile where
           .= field "legalhold_status" schema
         <*> profileSupportedProtocols .= supportedProtocolsObjectSchema
         <*> profileType .= fmap (fromMaybe UserTypeRegular) (optField "type" schema)
+        <*> profileSearchable .= fmap (fromMaybe True) (optField "searchable" schema)
 
 --------------------------------------------------------------------------------
 -- SelfProfile
@@ -603,7 +605,8 @@ data User = User
     -- | How is the user profile managed (e.g. if it's via SCIM then the user profile
     -- can't be edited via normal means)
     userManagedBy :: ManagedBy,
-    userSupportedProtocols :: Set BaseProtocolTag
+    userSupportedProtocols :: Set BaseProtocolTag,
+    userSearchable :: Bool
   }
   deriving stock (Eq, Ord, Show, Generic)
   deriving (Arbitrary) via (GenericUniform User)
@@ -654,6 +657,7 @@ userObjectSchema =
       .= (fromMaybe ManagedByWire <$> optField "managed_by" schema)
     <*> userSupportedProtocols .= supportedProtocolsObjectSchema
     <* (fromMaybe False <$> (\u -> if userDeleted u then Just True else Nothing) .= maybe_ (optField "deleted" schema))
+    <*> userSearchable .= (fromMaybe True <$> optField "searchable" schema)
 
 userEmail :: User -> Maybe EmailAddress
 userEmail = emailIdentity <=< userIdentity
@@ -732,7 +736,8 @@ mkUserProfileWithEmail memail u legalHoldStatus =
           profileEmail = memail,
           profileLegalholdStatus = legalHoldStatus,
           profileSupportedProtocols = userSupportedProtocols u,
-          profileType = ty
+          profileType = ty,
+          profileSearchable = userSearchable u
         }
 
 mkUserProfile :: EmailVisibilityConfigWithViewer -> User -> UserLegalHoldStatus -> UserProfile

libs/wire-api/src/Wire/API/User/Search.hs

@@ -193,7 +193,8 @@ data TeamContact = TeamContact
     teamContactScimExternalId :: Maybe Text,
     teamContactSso :: Maybe Sso,
     teamContactEmailUnvalidated :: Maybe EmailAddress,
-    teamContactUserGroups :: [UserGroupId]
+    teamContactUserGroups :: [UserGroupId],
+    teamContactSearchable :: Bool
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform TeamContact)
@@ -217,6 +218,7 @@ instance ToSchema TeamContact where
         <*> teamContactSso .= optField "sso" (maybeWithDefault Aeson.Null schema)
         <*> teamContactEmailUnvalidated .= optField "email_unvalidated" (maybeWithDefault Aeson.Null schema)
         <*> teamContactUserGroups .= fieldWithDocModifier "user_groups" (S.description ?~ "List of user group ids the user is a member of") (array schema)
+        <*> teamContactSearchable .= field "searchable" schema
 
 data TeamUserSearchSortBy
   = SortByName