WPB-20214: Add member searchability

integration/test/Test/Search.hs

@@ -12,6 +12,7 @@ import GHC.Stack
 import SetupHelpers
 import Testlib.Assertions
 import Testlib.Prelude
+import Debug.Trace
 
 --------------------------------------------------------------------------------
 -- LOCAL SEARCH
@@ -335,3 +336,101 @@ testTeamSearchEmailFilter = do
     ownerId <- objId owner
     memberId <- objId mem
     uids `shouldMatchSet` [ownerId, memberId]
+
+testUserSearchable :: App ()
+testUserSearchable = do
+  -- (owner, tid) <- createUserWithTeam brig
+  (owner, tid, mem : _) <- createTeam OwnDomain 2
+
+  let -- Helper to change user searchability.
+      setSearchable self uid searchable = do
+        req <- baseRequest self Brig Versioned $ joinHttpPath ["users", uid, "searchable"]
+        submit "POST" $ addJSON searchable req
+
+  -- partner <- createTeamMember owner def {role = "partner"}
+  -- Create user in team, default is searchable = True.
+  u1 <- createTeamMember owner def
+  assertBool "created users are searchable by default" =<< (u1 %. "searchable" & asBool)
+
+  -- Setting self to non-searchable won't work -- only admin can do it.
+  u1id <- u1 %. "id" & asString
+  setSearchable u1id u1id False `bindResponse` \resp ->
+    resp.status `shouldMatchInt` 403
+    resp.json %. "label" `shouldMatch` "insufficient-permissions"
+
+  -- refetch u1
+  -- assertBool "Searchable is still True" . profileSearchable =<< parseOrFail "UserProfile" (getProfile brig owner u1id)
+
+  traceShow u1 $ pure ()
+
+{-
+  -- Make a member in the current team
+  let mkTeamMember :: Permissions -> Http User
+      mkTeamMember perms = do
+        member <- createTeamMember brig galley owner tid perms
+        selfUser <$> (responseJsonError =<< get (brig . path "/self" . zUser (userId member)))
+
+
+  -- Team admin can set user to non-searchable.
+  admin <- userId <$> mkTeamMember (rolePermissions RoleAdmin)
+  post (setSearchable admin u1id False) !!! const 200 === statusCode
+  liftIO . assertBool "Searchable is now False" . not . profileSearchable =<< parseOrFail "UserProfile" (getProfile brig owner u1id)
+
+  -- Team owner can, too.
+  post (setSearchable owner u1id True) !!! const 200 === statusCode
+  post (setSearchable owner u1id False) !!! const 200 === statusCode
+
+  -- By default created team members are found.
+  u3 <- mkTeamMember (rolePermissions RoleMember)
+  Search.refreshIndex brig
+  s <- Search.executeSearch brig u1id $ fromName $ userDisplayName u3
+  liftIO $ assertBool "u1 must find u3 as they are searchable by default" $ uidsInResult [userId u3] s
+
+  -- Use set to non-searchable is not found by other team members.
+  u4 <- mkTeamMember (rolePermissions RoleMember)
+  post (setSearchable owner (userId u4) False) !!! const 200 === statusCode
+  Search.refreshIndex brig
+  s <- Search.executeSearch brig u1id $ fromName $ userDisplayName u4
+  liftIO $ assertBool "u1 must not find u4 as they are set non-searchable" $ not $ uidsInResult [userId u4] s
+
+  -- Even admin nor owner won't find non-searchable users via /search/contacts
+  sAdmin <- Search.executeSearch brig admin $ fromName $ userDisplayName u4
+  liftIO $ assertBool "Team admin won't find non-searchable user from /search/concatcs" $ not $ uidsInResult [userId u4] sAdmin
+  sOwner <- Search.executeSearch brig owner $ fromName $ userDisplayName u4
+  liftIO $ assertBool "Team owner won't find non-searchable user from /search/concatcs" $ not $ uidsInResult [userId u4] sOwner
+
+  -- Exact handle search with HTTP HEAD still works for non-searchable users
+  u4' <- setRandomHandle brig u4 -- Add handle to the non-searchable u4
+  let u4handle = fromJust $ userHandle u4'
+  Bilge.head (brig . paths ["handles", toByteString' u4handle] . zUser (userId u3))
+    !!! const 200 === statusCode
+
+  -- Regular user can't find non-searchable team member by exact handle.
+  s <- Search.executeSearch brig u1id $ fromHandle u4handle
+  liftIO $ assertBool "u1 must not find non-searchable u4 by exact handle" $ not $ uidsInResult [userId u4] s
+
+  -- /teams/:tid/members gets all members
+  r :: Team.Member.TeamMembersPage <- parseOrFail "TeamMembersPage" $ get (galley . paths ["teams", toByteString' tid, "members"] . zUser u1id) <!! const 200 === statusCode
+  let teamMembers = mtpResults $ Team.Member.unTeamMembersPage r :: [Team.Member.TeamMemberOptPerms]
+      uids = map (^. Team.Member.userId) teamMembers
+  liftIO $ assertBool "/teams/:tid/members returns searchable and non-searchable users from team" $ all (`elem` uids) $ u1id : map userId [u3, u4]
+
+  -- /teams/:tid/search?searchable=false gets only non-searchable members
+  r :: SearchResult TeamContact <- parseOrFail "SearchResult TeamContact" $
+    get ( brig
+          . paths ["teams", toByteString' tid, "search"]
+          . queryItem "searchable" "false"
+          . zUser admin) <!! const 200 === statusCode
+  let uids = map teamContactUserId $ searchResults r
+  liftIO $ assertBool "/teams/:tid/members?searchable=false returns only non-searchable members" $ userId u4 `elem` uids
+
+  where
+    contactUid :: Contact -> UserId
+    contactUid = qUnqualified . contactQualifiedId
+
+    uidsInResult :: [UserId] -> SearchResult Contact -> Bool
+    uidsInResult uids r = all (`elem` foundUids) uids
+      where
+        foundUids = map contactUid (searchResults r)
+-}
+  pure ()

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"
@@ -172,7 +171,6 @@ type UserAPI =
         :> GetUserVerb
     )
     :<|>
-    -- See Note [ephemeral user sideeffect]
     Named
       "get-user-qualified"
       ( Summary "Get a user by Domain and UserId"
@@ -225,7 +223,6 @@ type UserAPI =
                     (Maybe UserProfile)
            )
     :<|>
-    -- See Note [ephemeral user sideeffect]
     Named
       "list-users-by-unqualified-ids-or-handles"
       ( Summary "List users (deprecated)"
@@ -248,7 +245,6 @@ type UserAPI =
                :> Post '[JSON] ListUsersById
            )
     :<|>
-    -- See Note [ephemeral user sideeffect]
     Named
       "list-users-by-ids-or-handles@V3"
       ( Summary "List users"
@@ -294,6 +290,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."
 
@@ -1732,6 +1739,13 @@ type SearchAPI =
              ]
              "email"
              EmailVerificationFilter
+        :> QueryParam'
+             [ Optional,
+               Strict,
+               Description "Optional, return only non-seacrhable 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

@@ -192,7 +192,8 @@ data TeamContact = TeamContact
     teamContactRole :: Maybe Role,
     teamContactScimExternalId :: Maybe Text,
     teamContactSso :: Maybe Sso,
-    teamContactEmailUnvalidated :: Maybe EmailAddress
+    teamContactEmailUnvalidated :: Maybe EmailAddress,
+    teamContactSearchable :: Maybe Bool
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform TeamContact)
@@ -215,6 +216,7 @@ instance ToSchema TeamContact where
         <*> teamContactScimExternalId .= optField "scim_external_id" (maybeWithDefault Aeson.Null schema)
         <*> teamContactSso .= optField "sso" (maybeWithDefault Aeson.Null schema)
         <*> teamContactEmailUnvalidated .= optField "email_unvalidated" (maybeWithDefault Aeson.Null schema)
+        <*> teamContactSearchable .= optField "searchable" (maybeWithDefault Aeson.Null schema)
 
 data TeamUserSearchSortBy
   = SortByName