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" $ addJSONObject ["set_searchable" .= searchable] req
+
 getAPIVersion :: (HasCallStack, MakesValue domain) => domain -> App Response
 getAPIVersion domain = do
   req <- baseRequest domain Brig Unversioned $ "/api-version"
@@ -1207,8 +1212,14 @@ refreshAppCookie u tid appId = do
   req <- baseRequest u Brig Versioned $ joinHttpPath ["teams", tid, "apps", appId, "cookies"]
   submit "POST" req
 
-removeTeamCollaborator :: (MakesValue owner, MakesValue collaborator, HasCallStack) => owner -> String -> collaborator -> App Response
-removeTeamCollaborator owner tid collaborator = do
-  (_, collabId) <- objQid collaborator
-  req <- baseRequest owner Galley Versioned $ joinHttpPath ["teams", tid, "collaborators", collabId]
-  submit "DELETE" req
+-- | https://staging-nginz-https.zinfra.io/v12/api/swagger-ui/#/default/check-user-handle
+checkHandle :: (MakesValue user) => user -> String -> App Response
+checkHandle self handle = do
+  req <- baseRequest self Brig Versioned (joinHttpPath ["handles", handle])
+  submit "HEAD" req
+
+-- | https://staging-nginz-https.zinfra.io/v12/api/swagger-ui/#/default/check-user-handles
+checkHandles :: (MakesValue user) => user -> [String] -> App Response
+checkHandles self handles = do
+  req <- baseRequest self Brig Versioned (joinHttpPath ["handles"]) <&> addJSONObject ["handles" .= handles]
+  submit "POST" req

integration/test/API/Galley.hs

@@ -867,3 +867,9 @@ resetConversation user groupId epoch = do
   req <- baseRequest user Galley Versioned (joinHttpPath ["mls", "reset-conversation"])
   let payload = object ["group_id" .= groupId, "epoch" .= epoch]
   submit "POST" $ req & addJSON payload
+
+removeTeamCollaborator :: (MakesValue owner, MakesValue collaborator, HasCallStack) => owner -> String -> collaborator -> App Response
+removeTeamCollaborator owner tid collaborator = do
+  (_, collabId) <- objQid collaborator
+  req <- baseRequest owner Galley Versioned $ joinHttpPath ["teams", tid, "collaborators", collabId]
+  submit "DELETE" req

integration/test/Test/Search.hs

@@ -8,6 +8,7 @@ import qualified API.Common as API
 import API.Galley
 import qualified API.Galley as Galley
 import qualified API.GalleyInternal as GalleyI
+import qualified Data.Set as Set
 import GHC.Stack
 import SetupHelpers
 import Testlib.Assertions
@@ -358,3 +359,124 @@ testTeamSearchUserIncludesUserGroups = do
       let expectedUgs = fromMaybe [] (lookup uid expected)
       actualUgs <- for ugs asString
       actualUgs `shouldMatchSet` expectedUgs
+
+testUserSearchable :: App ()
+testUserSearchable = do
+  -- Create team and all users who are part of this test
+  (owner, tid, [u1, u2, u3]) <- createTeam OwnDomain 4
+  admin <- createTeamMember owner def {role = "admin"}
+  let everyone = [owner, u1, admin, u2, u3]
+  everyone'sUidSet <- Set.fromList <$> mapM objId everyone
+
+  -- 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.
+  u2id <- u2 %. "id" & asString
+  BrigI.refreshIndex OwnDomain
+  withFoundDocs u1 (u2 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "u1 must find u2 as they are searchable by default" $ u2id `elem` foundUids
+
+  -- User set to non-searchable is not found by other team members.
+  u3id <- u3 %. "id" & asString
+  BrigP.setUserSearchable owner u3id False `bindResponse` \resp -> resp.status `shouldMatchInt` 200
+  BrigI.refreshIndex OwnDomain
+  withFoundDocs u1 (u3 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "u1 must not find u3 as they are set non-searchable" $ notElem u3id foundUids
+
+  -- Even admin nor owner won't find non-searchable users via /search/contacts
+  withFoundDocs admin (u3 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "Team admin won't find non-searchable user" $ notElem u3id foundUids
+  withFoundDocs owner (u3 %. "name") $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "Team owner won't find non-searchable user from /search/contacts" $ notElem u3id foundUids
+
+  -- Check for handle being available with HTTP HEAD still shows that the handle used by non-searchable users is not available
+  u3handle <- API.randomHandle
+  BrigP.putHandle u3 u3handle `bindResponse` assertSuccess
+  BrigP.checkHandle u2 u3handle `bindResponse` \resp -> resp.status `shouldMatchInt` 200 -- (200 means "handle is taken", 404 would be "not found")
+
+  -- Handle for POST /handles still works for non-searchable users
+  u2handle <- API.randomHandle
+  BrigP.putHandle u2 u2handle `bindResponse` assertSuccess
+  BrigP.checkHandles u1 [u3handle, u2handle] `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 u3handle $ \docs -> do
+    foundUids <- for docs objId
+    assertBool "u1 must not find non-searchable u3 by exact handle" $ notElem u3id foundUids
+
+  -- /teams/:tid/members gets all members, both searchable and non-searchable
+  getTeamMembers u1 tid `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    docs <- resp.json %. "members" >>= asList
+    foundUids <- mapM (\m -> m %. "user" & asString) docs
+    assertBool "/teams/:tid/members returns all users in team"
+      $ Set.fromList foundUids
+      == everyone'sUidSet
+
+  -- /teams/:tid/search also returns all users from team
+  BrigP.searchTeam admin [] `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    docs <- resp.json %. "documents" >>= asList
+    foundUids <- mapM (\m -> m %. "id" & asString) docs
+    assertBool "/teams/:tid/search returns all users in team" $ Set.fromList foundUids == everyone'sUidSet
+
+  -- /teams/:tid/search?searchable=false gets only non-searchable members
+  BrigP.searchTeam admin [("searchable", "false")] `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, u3id]
+
+  -- /teams/:tid/search?searchable=true gets only searchable users
+  BrigP.searchTeam admin [("searchable", "true")] `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    docs <- resp.json %. "documents" >>= asList
+    foundUids <- mapM (\m -> m %. "id" & asString) docs
+    ownerUid <- owner %. "id" & asString
+    adminUid <- admin %. "id" & asString
+    assertBool "/teams/:tid/search?searchable=true gets only searchable users"
+      $ Set.fromList foundUids
+      == Set.fromList [ownerUid, adminUid, u2id]
+  where
+    -- Convenience wrapper around search contacts which applies `f` directly to document list.
+    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

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"
+               :> "searchable"
+               :> ReqBody '[JSON] SetSearchable
+               :> 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)