WPB-20214: Add member searchability

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,18 @@ 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"
+               :> Capture "tid" TeamId
+               :> 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."
 

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

@@ -17,6 +17,7 @@
 
 module Wire.API.Routes.Public.Galley.TeamMember where
 
+import Data.Bool
 import Data.Id
 import Data.Int
 import Data.Range
@@ -60,6 +61,13 @@ type TeamMemberAPI =
              ]
              "pagingState"
              TeamMembersPagingState
+        :> QueryParam'
+             [ Optional,
+               Strict,
+               Description "Optional, return only non-seacrhable members when false."
+             ]
+             "searchable"
+             Bool
         :> Get '[JSON] TeamMembersPage
     )
     :<|> Named

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

@@ -533,7 +533,8 @@ rolePerms RoleAdmin =
       [ AddTeamMember,
         RemoveTeamMember,
         SetTeamData,
-        SetMemberPermissions
+        SetMemberPermissions,
+        SetMemberSearchable
       ]
 rolePerms RoleMember =
   rolePerms RoleExternalPartner
@@ -654,7 +655,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
@@ -151,10 +154,9 @@ data Perm
   | SetMemberPermissions
   | GetTeamConversations
   | DeleteTeam
+  | SetMemberSearchable
   -- 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)
@@ -183,6 +185,7 @@ permToInt GetMemberPermissions = 0x0200
 permToInt GetTeamConversations = 0x0400
 permToInt DeleteTeam = 0x0800
 permToInt SetMemberPermissions = 0x1000
+permToInt SetMemberSearchable = 0x2000
 
 intToPerm :: Word64 -> Maybe Perm
 intToPerm 0x0001 = Just CreateConversation
@@ -198,6 +201,7 @@ intToPerm 0x0200 = Just GetMemberPermissions
 intToPerm 0x0400 = Just GetTeamConversations
 intToPerm 0x0800 = Just DeleteTeam
 intToPerm 0x1000 = Just SetMemberPermissions
+intToPerm 0x2000 = Just SetMemberSearchable
 intToPerm _ = Nothing
 
 instance Cql.Cql Permissions where

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/test/golden/Test/Wire/API/Golden/Generated/SelfProfile_user.hs

@@ -62,6 +62,7 @@ testObject_SelfProfile_user_1 =
             userExpire = Just (fromJust (readUTCTimeMillis "1864-05-07T21:09:29.342Z")),
             userTeam = Just (Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000000000002"))),
             userManagedBy = ManagedByScim,
-            userSupportedProtocols = defSupportedProtocols
+            userSupportedProtocols = defSupportedProtocols,
+            userSearchable = True
           }
     }

libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs

@@ -51,7 +51,8 @@ testObject_UserProfile_user_1 =
       profileEmail = Nothing,
       profileLegalholdStatus = UserLegalHoldDisabled,
       profileSupportedProtocols = defSupportedProtocols,
-      profileType = UserTypeRegular
+      profileType = UserTypeRegular,
+      profileSearchable = True
     }
 
 testObject_UserProfile_user_2 :: UserProfile
@@ -82,5 +83,6 @@ testObject_UserProfile_user_2 =
       profileEmail = Just (unsafeEmailAddress "some" "example"),
       profileLegalholdStatus = UserLegalHoldNoConsent,
       profileSupportedProtocols = defSupportedProtocols,
-      profileType = UserTypeApp
+      profileType = UserTypeApp,
+      profileSearchable = True
     }

libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs

@@ -68,7 +68,8 @@ testObject_User_user_1 =
       userExpire = Nothing,
       userTeam = Nothing,
       userManagedBy = ManagedByWire,
-      userSupportedProtocols = defSupportedProtocols
+      userSupportedProtocols = defSupportedProtocols,
+      userSearchable = True
     }
 
 testObject_User_user_2 :: User
@@ -107,7 +108,8 @@ testObject_User_user_2 =
       userExpire = Just (fromJust (readUTCTimeMillis "1864-05-11T17:06:58.936Z")),
       userTeam = Nothing,
       userManagedBy = ManagedByWire,
-      userSupportedProtocols = mempty
+      userSupportedProtocols = mempty,
+      userSearchable = True
     }
 
 testObject_User_user_3 :: User
@@ -139,7 +141,8 @@ testObject_User_user_3 =
       userExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T20:12:05.821Z")),
       userTeam = Just (Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000200000000"))),
       userManagedBy = ManagedByWire,
-      userSupportedProtocols = defSupportedProtocols
+      userSupportedProtocols = defSupportedProtocols,
+      userSearchable = True
     }
 
 testObject_User_user_4 :: User
@@ -176,7 +179,8 @@ testObject_User_user_4 =
       userExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T14:25:26.089Z")),
       userTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002"))),
       userManagedBy = ManagedByScim,
-      userSupportedProtocols = defSupportedProtocols
+      userSupportedProtocols = defSupportedProtocols,
+      userSearchable = True
     }
 
 testObject_User_user_5 :: User
@@ -213,5 +217,6 @@ testObject_User_user_5 =
       userExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T14:25:26.089Z")),
       userTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002"))),
       userManagedBy = ManagedByScim,
-      userSupportedProtocols = defSupportedProtocols
+      userSupportedProtocols = defSupportedProtocols,
+      userSearchable = True
     }

libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ListUsersById.hs

@@ -53,7 +53,8 @@ profile1 =
       profileEmail = Nothing,
       profileLegalholdStatus = UserLegalHoldDisabled,
       profileSupportedProtocols = defSupportedProtocols,
-      profileType = UserTypeRegular
+      profileType = UserTypeRegular,
+      profileSearchable = True
     }
 profile2 =
   UserProfile
@@ -71,7 +72,8 @@ profile2 =
       profileEmail = Nothing,
       profileLegalholdStatus = UserLegalHoldDisabled,
       profileSupportedProtocols = Set.fromList [BaseProtocolProteusTag, BaseProtocolMLSTag],
-      profileType = UserTypeRegular
+      profileType = UserTypeRegular,
+      profileSearchable = True
     }
 
 testObject_ListUsersById_user_1 :: ListUsersById

libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/UserEvent.hs

@@ -242,7 +242,8 @@ alice =
       userExpire = Nothing,
       userTeam = Just $ Id (fromJust (UUID.fromString "bb843450-b2f5-4ec8-90bd-52c7d5f1d22e")),
       userManagedBy = ManagedByWire,
-      userSupportedProtocols = defSupportedProtocols
+      userSupportedProtocols = defSupportedProtocols,
+      userSearchable = True
     }
 
 bob :: User
@@ -271,5 +272,6 @@ bob =
       userExpire = Nothing,
       userTeam = Nothing,
       userManagedBy = ManagedByWire,
-      userSupportedProtocols = defSupportedProtocols
+      userSupportedProtocols = defSupportedProtocols,
+      userSearchable = True
     }

libs/wire-api/test/unit/Test/Wire/API/User.hs

@@ -117,7 +117,7 @@ testUserProfile = do
   uid <- Id <$> UUID.nextRandom
   let domain = Domain "example.com"
   let colour = ColourId 0
-  let userProfile = UserProfile (Qualified uid domain) (Name "name") Nothing (Pict []) [] colour False Nothing Nothing Nothing Nothing Nothing UserLegalHoldNoConsent defSupportedProtocols UserTypeRegular
+  let userProfile = UserProfile (Qualified uid domain) (Name "name") Nothing (Pict []) [] colour False Nothing Nothing Nothing Nothing Nothing UserLegalHoldNoConsent defSupportedProtocols UserTypeRegular True
   let profileJSONAsText = show $ Aeson.encode userProfile
   let msg = "toJSON encoding must not convert Nothing to null, but instead omit those json fields for backwards compatibility. UserProfileJSON:" <> profileJSONAsText
   assertBool msg (not $ "null" `isInfixOf` profileJSONAsText)

libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs

@@ -156,7 +156,8 @@ appNewStoredUser creator new = do
         expires = Nothing,
         teamId = creator.teamId,
         managedBy = defaultManagedBy,
-        supportedProtocols = defAppSupportedProtocols
+        supportedProtocols = defAppSupportedProtocols,
+        searchable = True
       }
 
 defAppSupportedProtocols :: Set BaseProtocolTag

libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs

@@ -222,7 +222,8 @@ defaultUserQuery searcher mSearcherTeamId teamSearchInfo (normalized -> term') =
                         ES.boolQueryMustNotMatch = [termQ "handle" term']
                       }
                 ],
-              ES.boolQueryShouldMatch = [ES.QueryExistsQuery (ES.FieldName "handle")]
+              ES.boolQueryShouldMatch = [ES.QueryExistsQuery (ES.FieldName "handle")],
+              ES.boolQueryMustNotMatch = [ES.TermQuery (ES.Term "searchable" "false") Nothing]
             }
       -- 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

libs/wire-subsystems/src/Wire/StoredUser.hs

@@ -40,7 +40,8 @@ data StoredUser = StoredUser
     handle :: Maybe Handle,
     teamId :: Maybe TeamId,
     managedBy :: Maybe ManagedBy,
-    supportedProtocols :: Maybe (Set BaseProtocolTag)
+    supportedProtocols :: Maybe (Set BaseProtocolTag),
+    searchable :: Maybe Bool
   }
   deriving (Show, Eq, Ord, Generic)
   deriving (Arbitrary) via (GenericUniform StoredUser)
@@ -98,7 +99,8 @@ mkUserFromStored domain defaultLocale storedUser =
           userManagedBy = fromMaybe ManagedByWire storedUser.managedBy,
           userSupportedProtocols = case storedUser.supportedProtocols of
             Nothing -> defSupportedProtocols
-            Just ps -> if S.null ps then defSupportedProtocols else ps
+            Just ps -> if S.null ps then defSupportedProtocols else ps,
+          userSearchable = (fromMaybe True storedUser.searchable)
         }
 
 toLocale :: Locale -> (Maybe Language, Maybe Country) -> Locale
@@ -147,7 +149,8 @@ data NewStoredUser = NewStoredUser
     handle :: Maybe Handle,
     teamId :: Maybe TeamId,
     managedBy :: ManagedBy,
-    supportedProtocols :: Set BaseProtocolTag
+    supportedProtocols :: Set BaseProtocolTag,
+    searchable :: Bool
   }
   deriving (Show)
 
@@ -178,7 +181,8 @@ deriving instance
       Maybe Handle,
       Maybe TeamId,
       ManagedBy,
-      Set BaseProtocolTag
+      Set BaseProtocolTag,
+      Bool
     )
 
 instance HasField "service" NewStoredUser (Maybe ServiceRef) where
@@ -203,5 +207,6 @@ newStoredUserToUser (Qualified new domain) =
       userExpire = new.expires,
       userTeam = new.teamId,
       userManagedBy = new.managedBy,
-      userSupportedProtocols = new.supportedProtocols
+      userSupportedProtocols = new.supportedProtocols,
+      userSearchable = new.searchable
     }