WIP

libs/brig-types/src/Brig/Types/Search.hs

@@ -56,16 +56,6 @@ data TeamSearchInfo
   | -- | No search restrictions, all users are searched
     AllUsers
 
--- | Inbound search restrictions configured by team to-be-searched. Affects only
--- full-text search (i.e. search on the display name and the handle), not exact
--- handle search.
-data SearchVisibilityInbound
-  = -- | The user can only be found by users from the same team
-    SearchableByOwnTeam
-  | -- | The user can by found by any user of any team
-    SearchableByAllTeams
-  deriving (Eq, Show)
-
 instance Arbitrary SearchVisibilityInbound where
   arbitrary = elements [SearchableByOwnTeam, SearchableByAllTeams]
 

libs/cassandra-util/src/Cassandra/Util.hs

@@ -109,6 +109,7 @@ initCassandra settings Nothing logger = do
 -- | Read cassandra's writetimes https://docs.datastax.com/en/dse/5.1/cql/cql/cql_using/useWritetime.html
 -- as UTCTime values without any loss of precision
 newtype Writetime a = Writetime {writetimeToUTC :: UTCTime}
+  deriving (Functor)
 
 instance Cql (Writetime a) where
   ctype = Tagged BigIntColumn

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

@@ -22,6 +22,8 @@ import Data.Currency qualified as Currency
 import Data.Id
 import Data.Json.Util (UTCTimeMillis)
 import Data.Qualified
+import Data.Schema
+import GHC.TypeLits
 import Imports
 import Network.Wai.Utilities.Error qualified as Wai
 import Polysemy
@@ -108,6 +110,14 @@ data GalleyAPIAccess m a where
   GetAllFeatureConfigsForUser ::
     Maybe UserId ->
     GalleyAPIAccess m AllFeatureConfigs
+  GetFeatureConfigForTeam ::
+    ( IsFeatureConfig feature,
+      Typeable feature,
+      ToSchema feature,
+      KnownSymbol (FeatureSymbol feature)
+    ) =>
+    TeamId ->
+    GalleyAPIAccess m (WithStatus feature)
   GetVerificationCodeEnabled ::
     TeamId ->
     GalleyAPIAccess m Bool

libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs

@@ -25,7 +25,10 @@ import Data.Coerce (coerce)
 import Data.Currency qualified as Currency
 import Data.Id
 import Data.Json.Util (UTCTimeMillis)
+import Data.Proxy
 import Data.Qualified
+import Data.Schema (ToSchema)
+import GHC.TypeLits
 import Imports
 import Network.HTTP.Client qualified as HTTP
 import Network.HTTP.Types qualified as HTTP
@@ -80,6 +83,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint =
           GetTeamName id' -> getTeamName id'
           GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id'
           GetTeamSearchVisibility id' -> getTeamSearchVisibility id'
+          GetFeatureConfigForTeam tid -> getFeatureConfigForTeam tid
           ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al
           MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id''
           GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id'
@@ -432,6 +436,27 @@ getTeamSearchVisibility tid =
         . paths ["i", "teams", toByteString' tid, "search-visibility"]
         . expect2xx
 
+getFeatureConfigForTeam ::
+  forall feature r.
+  ( IsFeatureConfig feature,
+    Typeable feature,
+    ToSchema feature,
+    KnownSymbol (FeatureSymbol feature),
+    Member TinyLog r,
+    Member Rpc r,
+    Member (Error ParseException) r
+  ) =>
+  TeamId ->
+  Sem (Input Endpoint : r) (WithStatus feature)
+getFeatureConfigForTeam tid = do
+  debug $ remote "galley" . msg (val "Get feature config for team")
+  galleyRequest req >>= decodeBodyOrThrow "galley"
+  where
+    req =
+      method GET
+        . paths ["i", "teams", toByteString' tid, "features", toByteString' $ symbolVal @(FeatureSymbol feature) Proxy]
+        . expect2xx
+
 getVerificationCodeEnabled ::
   ( Member (Error ParseException) r,
     Member Rpc r,

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

@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Wire.IndexedUserStore where
+
+import Database.Bloodhound.Types
+import Polysemy
+import Wire.UserSearch.Types
+
+data IndexedUserStore m a where
+  Upsert :: DocId -> UserDoc -> VersionControl -> IndexedUserStore m ()
+
+makeSem ''IndexedUserStore

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

@@ -0,0 +1,71 @@
+module Wire.IndexedUserStore.ElasticSearch where
+
+import Database.Bloodhound qualified as ES
+import Imports
+import Polysemy
+import Polysemy.Error
+import Wire.IndexedUserStore
+import Wire.UserSearch.Types (UserDoc)
+
+data ESConn = ESConn
+  { env :: ES.BHEnv,
+    indexName :: ES.IndexName
+  }
+
+data IndexedUserStoreConfig = IndexedUserStoreConfig
+  { conn :: ESConn,
+    additionalConn :: Maybe ESConn
+  }
+
+data IndexedUserStoreError = IndexUpdateError ES.EsError
+
+interpretIndexedUserStoreES :: (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> InterpreterFor IndexedUserStore r
+interpretIndexedUserStoreES cfg =
+  interpret $ \case
+    Upsert docId userDoc versioning -> upsertImpl cfg docId userDoc versioning
+
+upsertImpl :: forall r. (Member (Embed IO) r, Member (Error IndexedUserStoreError) r) => IndexedUserStoreConfig -> ES.DocId -> UserDoc -> ES.VersionControl -> Sem r ()
+upsertImpl cfg docId userDoc versioning = do
+  runInBothES cfg indexDoc
+  where
+    indexDoc :: ES.IndexName -> ES.BH (Sem r) ()
+    indexDoc idx = do
+      r <- ES.indexDocument idx mappingName settings userDoc docId
+      unless (ES.isSuccess r || ES.isVersionConflict r) $ do
+        -- liftIO $ Prom.incCounter indexUpdateErrorCounter
+        res <- liftIO $ ES.parseEsResponse r
+        lift . throw . IndexUpdateError . either id id $ res
+    -- liftIO $ Prom.incCounter indexUpdateSuccessCounter
+
+    settings = ES.defaultIndexDocumentSettings {ES.idsVersionControl = versioning}
+
+runInBothES :: (Monad m) => IndexedUserStoreConfig -> (ES.IndexName -> ES.BH m a) -> m a
+runInBothES cfg f = do
+  x <- ES.runBH cfg.conn.env $ f cfg.conn.indexName
+  forM_ cfg.additionalConn $ \additional ->
+    ES.runBH additional.env $ f additional.indexName
+  pure x
+
+-- withDefaultESUrl :: (Member (Embed m) r) => Sem (Embed (ES.BH m) : r) a -> Sem r a
+-- withDefaultESUrl action = do
+--   bhEnv <- liftIndexIO $ asks idxElastic
+--   ES.runBH bhEnv action
+
+-- -- | When the additional URL is not provided, uses the default url.
+-- withAdditionalESUrl :: ES.BH m a -> m a
+-- withAdditionalESUrl action = do
+--   mAdditionalBHEnv <- liftIndexIO $ asks idxAdditionalElastic
+--   defaultBHEnv <- liftIndexIO $ asks idxElastic
+--   ES.runBH (fromMaybe defaultBHEnv mAdditionalBHEnv) action
+
+mappingName :: ES.MappingName
+mappingName = ES.MappingName "user"
+
+-- -- This is useful and necessary due to the lack of expressiveness in the bulk API
+-- indexUpdateToVersionControlText :: IndexDocUpdateType -> Text
+-- indexUpdateToVersionControlText IndexUpdateIfNewerVersion = "external_gt"
+-- indexUpdateToVersionControlText IndexUpdateIfSameOrNewerVersion = "external_gte"
+
+-- indexUpdateToVersionControl :: IndexDocUpdateType -> (ES.ExternalDocVersion -> ES.VersionControl)
+-- indexUpdateToVersionControl IndexUpdateIfNewerVersion = ES.ExternalGT
+-- indexUpdateToVersionControl IndexUpdateIfSameOrNewerVersion = ES.ExternalGTE

libs/wire-subsystems/src/Wire/UserSearch/Types.hs

@@ -0,0 +1,174 @@
+module Wire.UserSearch.Types where
+
+import Cassandra qualified as C
+import Cassandra.Util
+import Data.Aeson
+import Data.Attoparsec.ByteString
+import Data.ByteString.Builder
+import Data.ByteString.Conversion
+import Data.ByteString.Lazy
+import Data.Handle
+import Data.Id
+import Data.Json.Util
+import Data.Text.Encoding
+import Database.Bloodhound.Types
+import Imports
+import Test.QuickCheck
+import Wire.API.Team.Feature
+import Wire.API.Team.Role
+import Wire.API.User
+import Wire.API.User.Search
+
+newtype IndexVersion = IndexVersion {docVersion :: DocVersion}
+
+mkIndexVersion :: [Maybe (Writetime x)] -> IndexVersion
+mkIndexVersion writetimes =
+  let maxVersion = getMax . mconcat . fmap (Max . writetimeToInt64) $ catMaybes writetimes
+   in -- This minBound case would only get triggered when the maxVersion is <= 0
+      -- or >= 9.2e+18. First case can happen when the writetimes list is empty
+      -- or contains a timestamp before the unix epoch, which is unlikely.
+      -- Second case will happen in a few billion years. It is also not really a
+      -- restriction in ES, Bloodhound's authors' interpretation of the the ES
+      -- documentation caused this limiation, otherwise `maxBound :: Int64`,
+      -- would be acceptable by ES.
+      IndexVersion . fromMaybe minBound . mkDocVersion . fromIntegral $ maxVersion
+
+-- | Represents an ES *document*, ie. the subset of user attributes stored in ES.
+-- See also 'IndexUser'.
+--
+-- If a user is not searchable, e.g. because the account got
+-- suspended, all fields except for the user id are set to 'Nothing' and
+-- consequently removed from the index.
+data UserDoc = UserDoc
+  { udId :: UserId,
+    udTeam :: Maybe TeamId,
+    udName :: Maybe Name,
+    udNormalized :: Maybe Text,
+    udHandle :: Maybe Handle,
+    udEmail :: Maybe Email,
+    udColourId :: Maybe ColourId,
+    udAccountStatus :: Maybe AccountStatus,
+    udSAMLIdP :: Maybe Text,
+    udManagedBy :: Maybe ManagedBy,
+    udCreatedAt :: Maybe UTCTimeMillis,
+    udRole :: Maybe Role,
+    udSearchVisibilityInbound :: Maybe SearchVisibilityInbound,
+    udScimExternalId :: Maybe Text,
+    udSso :: Maybe Sso,
+    udEmailUnvalidated :: Maybe Email
+  }
+  deriving (Eq, Show)
+
+-- Note: Keep this compatible with the FromJSON instances
+-- of 'Contact' and 'TeamContact' from 'Wire.API.User.Search
+instance ToJSON UserDoc where
+  toJSON ud =
+    object
+      [ "id" .= udId ud,
+        "team" .= udTeam ud,
+        "name" .= udName ud,
+        "normalized" .= udNormalized ud,
+        "handle" .= udHandle ud,
+        "email" .= udEmail ud,
+        "accent_id" .= udColourId ud,
+        "account_status" .= udAccountStatus ud,
+        "saml_idp" .= udSAMLIdP ud,
+        "managed_by" .= udManagedBy ud,
+        "created_at" .= udCreatedAt ud,
+        "role" .= udRole ud,
+        searchVisibilityInboundFieldName .= udSearchVisibilityInbound ud,
+        "scim_external_id" .= udScimExternalId ud,
+        "sso" .= udSso ud,
+        "email_unvalidated" .= udEmailUnvalidated ud
+      ]
+
+instance FromJSON UserDoc where
+  parseJSON = withObject "UserDoc" $ \o ->
+    UserDoc
+      <$> o .: "id"
+      <*> o .:? "team"
+      <*> o .:? "name"
+      <*> o .:? "normalized"
+      <*> o .:? "handle"
+      <*> o .:? "email"
+      <*> o .:? "accent_id"
+      <*> o .:? "account_status"
+      <*> o .:? "saml_idp"
+      <*> o .:? "managed_by"
+      <*> o .:? "created_at"
+      <*> o .:? "role"
+      <*> o .:? searchVisibilityInboundFieldName
+      <*> o .:? "scim_external_id"
+      <*> o .:? "sso"
+      <*> o .:? "email_unvalidated"
+
+searchVisibilityInboundFieldName :: Key
+searchVisibilityInboundFieldName = "search_visibility_inbound"
+
+-- | Outbound search restrictions configured by team admin of the searcher. This
+-- value restricts the set of user that are searched.
+--
+-- See 'optionallySearchWithinTeam' for the effect on full-text search.
+--
+-- See 'mkTeamSearchInfo' for the business logic that defines the TeamSearchInfo
+-- value.
+--
+-- Search results might be affected by the inbound search restriction settings of
+-- the searched user. ('SearchVisibilityInbound')
+data TeamSearchInfo
+  = -- | Only users that are not part of any team are searched
+    NoTeam
+  | -- | Only users from the same team as the searcher are searched
+    TeamOnly TeamId
+  | -- | No search restrictions, all users are searched
+    AllUsers
+
+-- | Inbound search restrictions configured by team to-be-searched. Affects only
+-- full-text search (i.e. search on the display name and the handle), not exact
+-- handle search.
+data SearchVisibilityInbound
+  = -- | The user can only be found by users from the same team
+    SearchableByOwnTeam
+  | -- | The user can by found by any user of any team
+    SearchableByAllTeams
+  deriving (Eq, Show)
+
+instance Arbitrary SearchVisibilityInbound where
+  arbitrary = elements [SearchableByOwnTeam, SearchableByAllTeams]
+
+instance ToByteString SearchVisibilityInbound where
+  builder SearchableByOwnTeam = "searchable-by-own-team"
+  builder SearchableByAllTeams = "searchable-by-all-teams"
+
+instance FromByteString SearchVisibilityInbound where
+  parser =
+    SearchableByOwnTeam
+      <$ string "searchable-by-own-team"
+        <|> SearchableByAllTeams
+      <$ string "searchable-by-all-teams"
+
+instance C.Cql SearchVisibilityInbound where
+  ctype = C.Tagged C.IntColumn
+
+  toCql SearchableByOwnTeam = C.CqlInt 0
+  toCql SearchableByAllTeams = C.CqlInt 1
+
+  fromCql (C.CqlInt 0) = pure SearchableByOwnTeam
+  fromCql (C.CqlInt 1) = pure SearchableByAllTeams
+  fromCql n = Left $ "Unexpected SearchVisibilityInbound: " ++ show n
+
+defaultSearchVisibilityInbound :: SearchVisibilityInbound
+defaultSearchVisibilityInbound = SearchableByOwnTeam
+
+searchVisibilityInboundFromFeatureStatus :: FeatureStatus -> SearchVisibilityInbound
+searchVisibilityInboundFromFeatureStatus FeatureStatusDisabled = SearchableByOwnTeam
+searchVisibilityInboundFromFeatureStatus FeatureStatusEnabled = SearchableByAllTeams
+
+instance ToJSON SearchVisibilityInbound where
+  toJSON = String . decodeUtf8 . toStrict . toLazyByteString . builder
+
+instance FromJSON SearchVisibilityInbound where
+  parseJSON = withText "SearchVisibilityInbound" $ \str ->
+    case runParser (parser @SearchVisibilityInbound) (encodeUtf8 str) of
+      Left err -> fail err
+      Right result -> pure result

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

@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Wire.UserSearchSubsystem where
+
+import Data.Domain
+import Data.Id
+import Data.Qualified
+import Data.Range
+import Imports
+import Polysemy
+import Wire.API.User.Search
+
+data BrowseTeamFilters = BrowseTeamFilters
+  { teamId :: TeamId,
+    mQuery :: Maybe Text,
+    mRoleFilter :: Maybe RoleFilter,
+    mSortBy :: Maybe TeamUserSearchSortBy,
+    mSortOrder :: Maybe TeamUserSearchSortOrder
+  }
+
+data UserSearchSubsystem m a where
+  UpsertUser :: UserId -> UserSearchSubsystem m ()
+  SearchUser :: Local UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> UserSearchSubsystem m [Contact]
+  BrowseTeam :: UserId -> BrowseTeamFilters -> Maybe (Range 1 500 Int32) -> Maybe PagingState -> UserSearchSubsystem m [TeamContact]
+
+makeSem ''UserSearchSubsystem
+
+-- | This function exists because there are a lot query params and they cannot all become 'BrowseTeamFilters' automatically
+browseTeamHandler ::
+  (Member UserSearchSubsystem r) =>
+  UserId ->
+  TeamId ->
+  Maybe Text ->
+  Maybe RoleFilter ->
+  Maybe TeamUserSearchSortBy ->
+  Maybe TeamUserSearchSortOrder ->
+  Maybe (Range 1 500 Int32) ->
+  Maybe PagingState ->
+  Sem r [TeamContact]
+browseTeamHandler uid tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder mMaxResults mPagingState = do
+  let browseTeamFilters = BrowseTeamFilters tid mQuery mRoleFilter mTeamUserSearchSortBy mTeamUserSearchSortOrder
+  browseTeam uid browseTeamFilters mMaxResults mPagingState