{-# LANGUAGE RecordWildCards #-}

module Wire.IndexedUserStore.ElasticSearch where

import Control.Error (lastMay)
import Control.Exception (throwIO)
import Data.Aeson
import Data.Aeson.Key qualified as Key
import Data.ByteString qualified as LBS
import Data.ByteString.Builder
import Data.ByteString.Conversion
import Data.Id
import Data.Text qualified as Text
import Data.Text.Ascii
import Data.Text.Encoding qualified as Text
import Database.Bloodhound qualified as ES
import Imports
import Network.HTTP.Client
import Network.HTTP.Types
import Polysemy
import Wire.API.Team.Size (TeamSize (TeamSize))
import Wire.API.User.Search
import Wire.IndexedUserStore
import Wire.Sem.Metrics (Metrics)
import Wire.Sem.Metrics qualified as Metrics
import Wire.UserSearch.Metrics
import Wire.UserSearch.Types
import Wire.UserStore.IndexUser

data ESConn = ESConn
  { ESConn -> BHEnv
env :: ES.BHEnv,
    ESConn -> IndexName
indexName :: ES.IndexName
  }

data IndexedUserStoreConfig = IndexedUserStoreConfig
  { IndexedUserStoreConfig -> ESConn
conn :: ESConn,
    IndexedUserStoreConfig -> Maybe ESConn
additionalConn :: Maybe ESConn
  }

interpretIndexedUserStoreES ::
  ( Member (Embed IO) r,
    Member Metrics r
  ) =>
  IndexedUserStoreConfig ->
  InterpreterFor IndexedUserStore r
interpretIndexedUserStoreES :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Metrics r) =>
IndexedUserStoreConfig -> InterpreterFor IndexedUserStore r
interpretIndexedUserStoreES IndexedUserStoreConfig
cfg =
  (forall (rInitial :: EffectRow) x.
 IndexedUserStore (Sem rInitial) x -> Sem r x)
-> Sem (IndexedUserStore : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  IndexedUserStore (Sem rInitial) x -> Sem r x)
 -> Sem (IndexedUserStore : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    IndexedUserStore (Sem rInitial) x -> Sem r x)
-> Sem (IndexedUserStore : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
    Upsert DocId
docId UserDoc
userDoc VersionControl
versioning -> IndexedUserStoreConfig
-> DocId -> UserDoc -> VersionControl -> Sem r ()
forall (r :: EffectRow).
(Member (Embed IO) r, Member Metrics r) =>
IndexedUserStoreConfig
-> DocId -> UserDoc -> VersionControl -> Sem r ()
upsertImpl IndexedUserStoreConfig
cfg DocId
docId UserDoc
userDoc VersionControl
versioning
    UpdateTeamSearchVisibilityInbound TeamId
tid SearchVisibilityInbound
vis ->
      IndexedUserStoreConfig
-> TeamId -> SearchVisibilityInbound -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> TeamId -> SearchVisibilityInbound -> Sem r ()
updateTeamSearchVisibilityInboundImpl IndexedUserStoreConfig
cfg TeamId
tid SearchVisibilityInbound
vis
    BulkUpsert [(DocId, UserDoc, VersionControl)]
docs -> IndexedUserStoreConfig
-> [(DocId, UserDoc, VersionControl)] -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> [(DocId, UserDoc, VersionControl)] -> Sem r ()
bulkUpsertImpl IndexedUserStoreConfig
cfg [(DocId, UserDoc, VersionControl)]
docs
    IndexedUserStore (Sem rInitial) x
DoesIndexExist -> IndexedUserStoreConfig -> Sem r Bool
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig -> Sem r Bool
doesIndexExistImpl IndexedUserStoreConfig
cfg
    SearchUsers UserId
searcherId Maybe TeamId
mSearcherTeam TeamSearchInfo
teamSearchInfo Text
term Int
maxResults ->
      IndexedUserStoreConfig
-> UserId
-> Maybe TeamId
-> TeamSearchInfo
-> Text
-> Int
-> Sem r (SearchResult UserDoc)
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> UserId
-> Maybe TeamId
-> TeamSearchInfo
-> Text
-> Int
-> Sem r (SearchResult UserDoc)
searchUsersImpl IndexedUserStoreConfig
cfg UserId
searcherId Maybe TeamId
mSearcherTeam TeamSearchInfo
teamSearchInfo Text
term Int
maxResults
    PaginateTeamMembers BrowseTeamFilters
filters Int
maxResults Maybe PagingState
mPagingState ->
      IndexedUserStoreConfig
-> BrowseTeamFilters
-> Int
-> Maybe PagingState
-> Sem r (SearchResult UserDoc)
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> BrowseTeamFilters
-> Int
-> Maybe PagingState
-> Sem r (SearchResult UserDoc)
paginateTeamMembersImpl IndexedUserStoreConfig
cfg BrowseTeamFilters
filters Int
maxResults Maybe PagingState
mPagingState
    GetTeamSize TeamId
tid -> IndexedUserStoreConfig -> TeamId -> Sem r TeamSize
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig -> TeamId -> Sem r TeamSize
getTeamSizeImpl IndexedUserStoreConfig
cfg TeamId
tid

getTeamSizeImpl ::
  ( Member (Embed IO) r
  ) =>
  IndexedUserStoreConfig ->
  TeamId ->
  Sem r TeamSize
getTeamSizeImpl :: forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig -> TeamId -> Sem r TeamSize
getTeamSizeImpl IndexedUserStoreConfig
cfg TeamId
tid = do
  let indexName :: IndexName
indexName = IndexedUserStoreConfig
cfg.conn.indexName
  Either EsError CountResponse
countResEither <- IO (Either EsError CountResponse)
-> Sem r (Either EsError CountResponse)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Either EsError CountResponse)
 -> Sem r (Either EsError CountResponse))
-> IO (Either EsError CountResponse)
-> Sem r (Either EsError CountResponse)
forall a b. (a -> b) -> a -> b
$ BHEnv
-> BH IO (Either EsError CountResponse)
-> IO (Either EsError CountResponse)
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH IndexedUserStoreConfig
cfg.conn.env (BH IO (Either EsError CountResponse)
 -> IO (Either EsError CountResponse))
-> BH IO (Either EsError CountResponse)
-> IO (Either EsError CountResponse)
forall a b. (a -> b) -> a -> b
$ IndexName -> CountQuery -> BH IO (Either EsError CountResponse)
forall (m :: * -> *).
(MonadBH m, MonadThrow m) =>
IndexName -> CountQuery -> m (Either EsError CountResponse)
ES.countByIndex IndexName
indexName (Query -> CountQuery
ES.CountQuery Query
query)
  CountResponse
countRes <- (EsError -> Sem r CountResponse)
-> (CountResponse -> Sem r CountResponse)
-> Either EsError CountResponse
-> Sem r CountResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO CountResponse -> Sem r CountResponse
forall a. IO a -> Sem r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CountResponse -> Sem r CountResponse)
-> (EsError -> IO CountResponse) -> EsError -> Sem r CountResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexedUserStoreError -> IO CountResponse
forall e a. Exception e => e -> IO a
throwIO (IndexedUserStoreError -> IO CountResponse)
-> (EsError -> IndexedUserStoreError)
-> EsError
-> IO CountResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EsError -> IndexedUserStoreError
IndexLookupError) CountResponse -> Sem r CountResponse
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either EsError CountResponse
countResEither
  TeamSize -> Sem r TeamSize
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TeamSize -> Sem r TeamSize)
-> (Natural -> TeamSize) -> Natural -> Sem r TeamSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> TeamSize
TeamSize (Natural -> Sem r TeamSize) -> Natural -> Sem r TeamSize
forall a b. (a -> b) -> a -> b
$ CountResponse -> Natural
ES.crCount CountResponse
countRes
  where
    query :: Query
query =
      Term -> Maybe Boost -> Query
ES.TermQuery
        ES.Term
          { termField :: Text
ES.termField = Text
"team",
            termValue :: Text
ES.termValue = TeamId -> Text
forall {k} (a :: k). Id a -> Text
idToText TeamId
tid
          }
        Maybe Boost
forall a. Maybe a
Nothing

upsertImpl ::
  forall r.
  ( Member (Embed IO) r,
    Member Metrics r
  ) =>
  IndexedUserStoreConfig ->
  ES.DocId ->
  UserDoc ->
  ES.VersionControl ->
  Sem r ()
upsertImpl :: forall (r :: EffectRow).
(Member (Embed IO) r, Member Metrics r) =>
IndexedUserStoreConfig
-> DocId -> UserDoc -> VersionControl -> Sem r ()
upsertImpl IndexedUserStoreConfig
cfg DocId
docId UserDoc
userDoc VersionControl
versioning = do
  Sem r ((), Maybe ()) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r ((), Maybe ()) -> Sem r ())
-> Sem r ((), Maybe ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ IndexedUserStoreConfig
-> (IndexName -> BH (Sem r) ()) -> Sem r ((), Maybe ())
forall (m :: * -> *) a.
Monad m =>
IndexedUserStoreConfig -> (IndexName -> BH m a) -> m (a, Maybe a)
runInBothES IndexedUserStoreConfig
cfg IndexName -> BH (Sem r) ()
indexDoc
  where
    indexDoc :: ES.IndexName -> ES.BH (Sem r) ()
    indexDoc :: IndexName -> BH (Sem r) ()
indexDoc IndexName
idx = do
      Reply
r <- IndexName
-> MappingName
-> IndexDocumentSettings
-> UserDoc
-> DocId
-> BH (Sem r) Reply
forall doc (m :: * -> *).
(ToJSON doc, MonadBH m) =>
IndexName
-> MappingName -> IndexDocumentSettings -> doc -> DocId -> m Reply
ES.indexDocument IndexName
idx MappingName
mappingName IndexDocumentSettings
settings UserDoc
userDoc DocId
docId
      Bool -> BH (Sem r) () -> BH (Sem r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Reply -> Bool
ES.isSuccess Reply
r Bool -> Bool -> Bool
|| Reply -> Bool
ES.isVersionConflict Reply
r) (BH (Sem r) () -> BH (Sem r) ()) -> BH (Sem r) () -> BH (Sem r) ()
forall a b. (a -> b) -> a -> b
$ do
        Sem r () -> BH (Sem r) ()
forall (m :: * -> *) a. Monad m => m a -> BH m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Sem r () -> BH (Sem r) ()) -> Sem r () -> BH (Sem r) ()
forall a b. (a -> b) -> a -> b
$ Counter -> Sem r ()
forall (r :: EffectRow). Member Metrics r => Counter -> Sem r ()
Metrics.incCounter Counter
indexUpdateErrorCounter
        Either EsError EsError
res <- IO (Either EsError EsError) -> BH (Sem r) (Either EsError EsError)
forall a. IO a -> BH (Sem r) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either EsError EsError)
 -> BH (Sem r) (Either EsError EsError))
-> IO (Either EsError EsError)
-> BH (Sem r) (Either EsError EsError)
forall a b. (a -> b) -> a -> b
$ Reply -> IO (Either EsError EsError)
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Reply -> m (Either EsError a)
ES.parseEsResponse Reply
r
        IO () -> BH (Sem r) ()
forall a. IO a -> BH (Sem r) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BH (Sem r) ())
-> (Either EsError EsError -> IO ())
-> Either EsError EsError
-> BH (Sem r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexedUserStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IndexedUserStoreError -> IO ())
-> (Either EsError EsError -> IndexedUserStoreError)
-> Either EsError EsError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EsError -> IndexedUserStoreError
IndexUpdateError (EsError -> IndexedUserStoreError)
-> (Either EsError EsError -> EsError)
-> Either EsError EsError
-> IndexedUserStoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EsError -> EsError)
-> (EsError -> EsError) -> Either EsError EsError -> EsError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either EsError -> EsError
forall a. a -> a
id EsError -> EsError
forall a. a -> a
id (Either EsError EsError -> BH (Sem r) ())
-> Either EsError EsError -> BH (Sem r) ()
forall a b. (a -> b) -> a -> b
$ Either EsError EsError
res
      Sem r () -> BH (Sem r) ()
forall (m :: * -> *) a. Monad m => m a -> BH m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Sem r () -> BH (Sem r) ()) -> Sem r () -> BH (Sem r) ()
forall a b. (a -> b) -> a -> b
$ Counter -> Sem r ()
forall (r :: EffectRow). Member Metrics r => Counter -> Sem r ()
Metrics.incCounter Counter
indexUpdateSuccessCounter

    settings :: IndexDocumentSettings
settings = IndexDocumentSettings
ES.defaultIndexDocumentSettings {ES.idsVersionControl = versioning}

updateTeamSearchVisibilityInboundImpl :: forall r. (Member (Embed IO) r) => IndexedUserStoreConfig -> TeamId -> SearchVisibilityInbound -> Sem r ()
updateTeamSearchVisibilityInboundImpl :: forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> TeamId -> SearchVisibilityInbound -> Sem r ()
updateTeamSearchVisibilityInboundImpl IndexedUserStoreConfig
cfg TeamId
tid SearchVisibilityInbound
vis =
  Sem r ((), Maybe ()) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r ((), Maybe ()) -> Sem r ())
-> Sem r ((), Maybe ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ IndexedUserStoreConfig
-> (IndexName -> BH (Sem r) ()) -> Sem r ((), Maybe ())
forall (m :: * -> *) a.
Monad m =>
IndexedUserStoreConfig -> (IndexName -> BH m a) -> m (a, Maybe a)
runInBothES IndexedUserStoreConfig
cfg IndexName -> BH (Sem r) ()
updateAllDocs
  where
    updateAllDocs :: ES.IndexName -> ES.BH (Sem r) ()
    updateAllDocs :: IndexName -> BH (Sem r) ()
updateAllDocs IndexName
idx = do
      Reply
r <- IndexName -> Query -> Maybe Script -> BH (Sem r) Reply
forall (m :: * -> *).
MonadBH m =>
IndexName -> Query -> Maybe Script -> m Reply
ES.updateByQuery IndexName
idx Query
query (Script -> Maybe Script
forall a. a -> Maybe a
Just Script
script)
      Bool -> BH (Sem r) () -> BH (Sem r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Reply -> Bool
ES.isSuccess Reply
r Bool -> Bool -> Bool
|| Reply -> Bool
ES.isVersionConflict Reply
r) (BH (Sem r) () -> BH (Sem r) ()) -> BH (Sem r) () -> BH (Sem r) ()
forall a b. (a -> b) -> a -> b
$ do
        Either EsError EsError
res <- IO (Either EsError EsError) -> BH (Sem r) (Either EsError EsError)
forall a. IO a -> BH (Sem r) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either EsError EsError)
 -> BH (Sem r) (Either EsError EsError))
-> IO (Either EsError EsError)
-> BH (Sem r) (Either EsError EsError)
forall a b. (a -> b) -> a -> b
$ Reply -> IO (Either EsError EsError)
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Reply -> m (Either EsError a)
ES.parseEsResponse Reply
r
        IO () -> BH (Sem r) ()
forall a. IO a -> BH (Sem r) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BH (Sem r) ())
-> (Either EsError EsError -> IO ())
-> Either EsError EsError
-> BH (Sem r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexedUserStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IndexedUserStoreError -> IO ())
-> (Either EsError EsError -> IndexedUserStoreError)
-> Either EsError EsError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EsError -> IndexedUserStoreError
IndexUpdateError (EsError -> IndexedUserStoreError)
-> (Either EsError EsError -> EsError)
-> Either EsError EsError
-> IndexedUserStoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EsError -> EsError)
-> (EsError -> EsError) -> Either EsError EsError -> EsError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either EsError -> EsError
forall a. a -> a
id EsError -> EsError
forall a. a -> a
id (Either EsError EsError -> BH (Sem r) ())
-> Either EsError EsError -> BH (Sem r) ()
forall a b. (a -> b) -> a -> b
$ Either EsError EsError
res

    query :: ES.Query
    query :: Query
query = Term -> Maybe Boost -> Query
ES.TermQuery (Text -> Text -> Term
ES.Term Text
"team" (Text -> Term) -> Text -> Term
forall a b. (a -> b) -> a -> b
$ TeamId -> Text
forall {k} (a :: k). Id a -> Text
idToText TeamId
tid) Maybe Boost
forall a. Maybe a
Nothing

    script :: ES.Script
    script :: Script
script = Maybe ScriptLanguage
-> Maybe ScriptInline
-> Maybe ScriptId
-> Maybe ScriptParams
-> Script
ES.Script (ScriptLanguage -> Maybe ScriptLanguage
forall a. a -> Maybe a
Just (Text -> ScriptLanguage
ES.ScriptLanguage Text
"painless")) (ScriptInline -> Maybe ScriptInline
forall a. a -> Maybe a
Just (Text -> ScriptInline
ES.ScriptInline Text
scriptText)) Maybe ScriptId
forall a. Maybe a
Nothing Maybe ScriptParams
forall a. Maybe a
Nothing

    -- Unfortunately ES disallows updating ctx._version with a "Update By Query"
    scriptText :: Text
scriptText =
      Text
"ctx._source."
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
Key.toText Key
searchVisibilityInboundFieldName
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = '"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeUtf8 (SearchVisibilityInbound -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' SearchVisibilityInbound
vis)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"';"

bulkUpsertImpl :: (Member (Embed IO) r) => IndexedUserStoreConfig -> [(ES.DocId, UserDoc, ES.VersionControl)] -> Sem r ()
bulkUpsertImpl :: forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> [(DocId, UserDoc, VersionControl)] -> Sem r ()
bulkUpsertImpl IndexedUserStoreConfig
cfg [(DocId, UserDoc, VersionControl)]
docs = do
  let bhe :: BHEnv
bhe = IndexedUserStoreConfig
cfg.conn.env
      ES.IndexName Text
idx = IndexedUserStoreConfig
cfg.conn.indexName
      ES.MappingName Text
mpp = MappingName
mappingName
      (ES.Server Text
base) = BHEnv -> Server
ES.bhServer BHEnv
bhe
  Request
baseReq <- IO Request -> Sem r Request
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Request -> Sem r Request) -> IO Request -> Sem r Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mpp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/_bulk")
  let reqWithoutCreds :: Request
reqWithoutCreds =
        Request
baseReq
          { method = "POST",
            requestHeaders = [(hContentType, "application/x-ndjson")],
            requestBody = RequestBodyLBS (toLazyByteString (foldMap encodeActionAndData docs))
          }
  Request
req <- IO Request -> Sem r Request
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Request -> Sem r Request) -> IO Request -> Sem r Request
forall a b. (a -> b) -> a -> b
$ BHEnv
bhe.bhRequestHook Request
reqWithoutCreds
  Reply
res <- IO Reply -> Sem r Reply
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Reply -> Sem r Reply) -> IO Reply -> Sem r Reply
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO Reply
httpLbs Request
req (BHEnv -> Manager
ES.bhManager BHEnv
bhe)
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Reply -> Bool
ES.isSuccess Reply
res) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    Either EsError EsError
parsedRes <- IO (Either EsError EsError) -> Sem r (Either EsError EsError)
forall a. IO a -> Sem r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either EsError EsError) -> Sem r (Either EsError EsError))
-> IO (Either EsError EsError) -> Sem r (Either EsError EsError)
forall a b. (a -> b) -> a -> b
$ Reply -> IO (Either EsError EsError)
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Reply -> m (Either EsError a)
ES.parseEsResponse Reply
res
    IO () -> Sem r ()
forall a. IO a -> Sem r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sem r ())
-> (Either EsError EsError -> IO ())
-> Either EsError EsError
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexedUserStoreError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IndexedUserStoreError -> IO ())
-> (Either EsError EsError -> IndexedUserStoreError)
-> Either EsError EsError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EsError -> IndexedUserStoreError
IndexUpdateError (EsError -> IndexedUserStoreError)
-> (Either EsError EsError -> EsError)
-> Either EsError EsError
-> IndexedUserStoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EsError -> EsError)
-> (EsError -> EsError) -> Either EsError EsError -> EsError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either EsError -> EsError
forall a. a -> a
id EsError -> EsError
forall a. a -> a
id (Either EsError EsError -> Sem r ())
-> Either EsError EsError -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Either EsError EsError
parsedRes
  where
    encodeJSONToString :: (ToJSON a) => a -> Builder
    encodeJSONToString :: forall a. ToJSON a => a -> Builder
encodeJSONToString = Encoding' Value -> Builder
forall tag. Encoding' tag -> Builder
fromEncoding (Encoding' Value -> Builder)
-> (a -> Encoding' Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding

    encodeActionAndData :: (ES.DocId, UserDoc, ES.VersionControl) -> Builder
    encodeActionAndData :: (DocId, UserDoc, VersionControl) -> Builder
encodeActionAndData (DocId
docId, UserDoc
userDoc, VersionControl
versionControl) =
      Value -> Builder
forall a. ToJSON a => a -> Builder
encodeJSONToString (DocId -> VersionControl -> Value
bulkIndexAction DocId
docId VersionControl
versionControl)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> UserDoc -> Builder
forall a. ToJSON a => a -> Builder
encodeJSONToString UserDoc
userDoc
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

    bulkIndexAction :: ES.DocId -> ES.VersionControl -> Value
    bulkIndexAction :: DocId -> VersionControl -> Value
bulkIndexAction DocId
docId VersionControl
versionControl =
      let (Maybe Text
versionType :: Maybe Text, Maybe DocVersion
version) = case VersionControl
versionControl of
            VersionControl
ES.NoVersionControl -> (Maybe Text
forall a. Maybe a
Nothing, Maybe DocVersion
forall a. Maybe a
Nothing)
            ES.InternalVersion DocVersion
v -> (Maybe Text
forall a. Maybe a
Nothing, DocVersion -> Maybe DocVersion
forall a. a -> Maybe a
Just DocVersion
v)
            ES.ExternalGT (ES.ExternalDocVersion DocVersion
v) -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"external", DocVersion -> Maybe DocVersion
forall a. a -> Maybe a
Just DocVersion
v)
            ES.ExternalGTE (ES.ExternalDocVersion DocVersion
v) -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"external_gte", DocVersion -> Maybe DocVersion
forall a. a -> Maybe a
Just DocVersion
v)
            ES.ForceVersion (ES.ExternalDocVersion DocVersion
v) -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"force", DocVersion -> Maybe DocVersion
forall a. a -> Maybe a
Just DocVersion
v)
       in [Pair] -> Value
object
            [ Key
"index"
                Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [Pair] -> Value
object
                  [ Key
"_id" Key -> DocId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= DocId
docId,
                    Key
"_version_type" Key -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Maybe Text
versionType,
                    Key
"_version" Key -> Maybe DocVersion -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Maybe DocVersion
version
                  ]
            ]

doesIndexExistImpl :: (Member (Embed IO) r) => IndexedUserStoreConfig -> Sem r Bool
doesIndexExistImpl :: forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig -> Sem r Bool
doesIndexExistImpl IndexedUserStoreConfig
cfg = do
  (Bool
mainExists, Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True -> Bool
additionalExists) <- IndexedUserStoreConfig
-> (IndexName -> BH (Sem r) Bool) -> Sem r (Bool, Maybe Bool)
forall (m :: * -> *) a.
Monad m =>
IndexedUserStoreConfig -> (IndexName -> BH m a) -> m (a, Maybe a)
runInBothES IndexedUserStoreConfig
cfg IndexName -> BH (Sem r) Bool
forall (m :: * -> *). MonadBH m => IndexName -> m Bool
ES.indexExists
  Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Sem r Bool) -> Bool -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ Bool
mainExists Bool -> Bool -> Bool
&& Bool
additionalExists

searchUsersImpl ::
  (Member (Embed IO) r) =>
  IndexedUserStoreConfig ->
  UserId ->
  Maybe TeamId ->
  TeamSearchInfo ->
  Text ->
  Int ->
  Sem r (SearchResult UserDoc)
searchUsersImpl :: forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> UserId
-> Maybe TeamId
-> TeamSearchInfo
-> Text
-> Int
-> Sem r (SearchResult UserDoc)
searchUsersImpl IndexedUserStoreConfig
cfg UserId
searcherId Maybe TeamId
mSearcherTeam TeamSearchInfo
teamSearchInfo Text
term Int
maxResults =
  IndexedUserStoreConfig
-> Int -> IndexQuery Contact -> Sem r (SearchResult UserDoc)
forall {k} (r :: EffectRow) (x :: k).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> Int -> IndexQuery x -> Sem r (SearchResult UserDoc)
queryIndex IndexedUserStoreConfig
cfg Int
maxResults (IndexQuery Contact -> Sem r (SearchResult UserDoc))
-> IndexQuery Contact -> Sem r (SearchResult UserDoc)
forall a b. (a -> b) -> a -> b
$
    UserId
-> Maybe TeamId -> TeamSearchInfo -> Text -> IndexQuery Contact
defaultUserQuery UserId
searcherId Maybe TeamId
mSearcherTeam TeamSearchInfo
teamSearchInfo Text
term

-- | The default or canonical 'IndexQuery'.
--
-- The intention behind parameterising 'queryIndex' over the 'IndexQuery' is that
-- it allows to experiment with different queries (perhaps in an A/B context).
--
-- FUTUREWORK: Drop legacyPrefixMatch
defaultUserQuery :: UserId -> Maybe TeamId -> TeamSearchInfo -> Text -> IndexQuery Contact
defaultUserQuery :: UserId
-> Maybe TeamId -> TeamSearchInfo -> Text -> IndexQuery Contact
defaultUserQuery UserId
searcher Maybe TeamId
mSearcherTeamId TeamSearchInfo
teamSearchInfo (Text -> Text
normalized -> Text
term') =
  let matchPhraseOrPrefix :: Query
matchPhraseOrPrefix =
        MultiMatchQuery -> Query
ES.QueryMultiMatchQuery (MultiMatchQuery -> Query) -> MultiMatchQuery -> Query
forall a b. (a -> b) -> a -> b
$
          ( [FieldName] -> QueryString -> MultiMatchQuery
ES.mkMultiMatchQuery
              [ Text -> FieldName
ES.FieldName Text
"handle.prefix^2",
                Text -> FieldName
ES.FieldName Text
"normalized.prefix",
                Text -> FieldName
ES.FieldName Text
"normalized^3"
              ]
              (Text -> QueryString
ES.QueryString Text
term')
          )
            { ES.multiMatchQueryType = Just ES.MultiMatchMostFields,
              ES.multiMatchQueryOperator = ES.And
            }
      query :: Query
query =
        BoolQuery -> Query
ES.QueryBoolQuery
          BoolQuery
boolQuery
            { ES.boolQueryMustMatch =
                [ ES.QueryBoolQuery
                    boolQuery
                      { ES.boolQueryShouldMatch = [matchPhraseOrPrefix],
                        -- This removes exact handle matches, as they are fetched from cassandra
                        ES.boolQueryMustNotMatch = [termQ "handle" term']
                      }
                ],
              ES.boolQueryShouldMatch = [ES.QueryExistsQuery (ES.FieldName "handle")]
            }
      -- 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
      -- relevance is not reduced for any users.
      queryWithBoost :: Query
queryWithBoost =
        BoostingQuery -> Query
ES.QueryBoostingQuery
          ES.BoostingQuery
            { positiveQuery :: Query
ES.positiveQuery = Query
query,
              negativeQuery :: Query
ES.negativeQuery = Query -> (TeamId -> Query) -> Maybe TeamId -> Query
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Query
ES.QueryMatchNoneQuery TeamId -> Query
matchUsersNotInTeam Maybe TeamId
mSearcherTeamId,
              negativeBoost :: Boost
ES.negativeBoost = Double -> Boost
ES.Boost Double
0.1
            }
   in UserId
-> Maybe TeamId -> TeamSearchInfo -> Query -> IndexQuery Contact
mkUserQuery UserId
searcher Maybe TeamId
mSearcherTeamId TeamSearchInfo
teamSearchInfo Query
queryWithBoost

paginateTeamMembersImpl ::
  (Member (Embed IO) r) =>
  IndexedUserStoreConfig ->
  BrowseTeamFilters ->
  Int ->
  Maybe PagingState ->
  Sem r (SearchResult UserDoc)
paginateTeamMembersImpl :: forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> BrowseTeamFilters
-> Int
-> Maybe PagingState
-> Sem r (SearchResult UserDoc)
paginateTeamMembersImpl IndexedUserStoreConfig
cfg BrowseTeamFilters {Maybe Text
Maybe RoleFilter
Maybe TeamUserSearchSortOrder
Maybe TeamUserSearchSortBy
TeamId
teamId :: TeamId
mQuery :: Maybe Text
mRoleFilter :: Maybe RoleFilter
mSortBy :: Maybe TeamUserSearchSortBy
mSortOrder :: Maybe TeamUserSearchSortOrder
$sel:teamId:BrowseTeamFilters :: BrowseTeamFilters -> TeamId
$sel:mQuery:BrowseTeamFilters :: BrowseTeamFilters -> Maybe Text
$sel:mRoleFilter:BrowseTeamFilters :: BrowseTeamFilters -> Maybe RoleFilter
$sel:mSortBy:BrowseTeamFilters :: BrowseTeamFilters -> Maybe TeamUserSearchSortBy
$sel:mSortOrder:BrowseTeamFilters :: BrowseTeamFilters -> Maybe TeamUserSearchSortOrder
..} Int
maxResults Maybe PagingState
mPagingState = do
  let (IndexQuery Query
q Filter
f [DefaultSort]
sortSpecs) =
        TeamId
-> Maybe Text
-> Maybe RoleFilter
-> Maybe TeamUserSearchSortBy
-> Maybe TeamUserSearchSortOrder
-> IndexQuery TeamContact
teamUserSearchQuery TeamId
teamId Maybe Text
mQuery Maybe RoleFilter
mRoleFilter Maybe TeamUserSearchSortBy
mSortBy Maybe TeamUserSearchSortOrder
mSortOrder
  let search :: Search
search =
        (Maybe Query -> Maybe Filter -> Search
ES.mkSearch (Query -> Maybe Query
forall a. a -> Maybe a
Just Query
q) (Filter -> Maybe Filter
forall a. a -> Maybe a
Just Filter
f))
          { -- we are requesting one more result than the page size to determine if there is a next page
            ES.size = ES.Size (fromIntegral maxResults + 1),
            ES.sortBody = Just (fmap ES.DefaultSortSpec sortSpecs),
            ES.searchAfterKey = toSearchAfterKey =<< mPagingState
          }
  SearchResult UserDoc -> SearchResult UserDoc
mkResult (SearchResult UserDoc -> SearchResult UserDoc)
-> Sem r (SearchResult UserDoc) -> Sem r (SearchResult UserDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IndexedUserStoreConfig -> Search -> Sem r (SearchResult UserDoc)
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig -> Search -> Sem r (SearchResult UserDoc)
searchInMainIndex IndexedUserStoreConfig
cfg Search
search
  where
    toSearchAfterKey :: PagingState -> Maybe b
toSearchAfterKey PagingState
ps = ByteString -> Maybe b
forall a. FromJSON a => ByteString -> Maybe a
decode' (ByteString -> Maybe b)
-> (ByteString -> ByteString) -> ByteString -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> Maybe b) -> Maybe ByteString -> Maybe b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AsciiBase64Url -> Maybe ByteString
decodeBase64Url (AsciiBase64Url -> Maybe ByteString)
-> (PagingState -> AsciiBase64Url)
-> PagingState
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PagingState -> AsciiBase64Url
unPagingState) PagingState
ps

    fromSearchAfterKey :: ES.SearchAfterKey -> PagingState
    fromSearchAfterKey :: SearchAfterKey -> PagingState
fromSearchAfterKey = AsciiBase64Url -> PagingState
PagingState (AsciiBase64Url -> PagingState)
-> (SearchAfterKey -> AsciiBase64Url)
-> SearchAfterKey
-> PagingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> AsciiBase64Url
encodeBase64Url (ByteString -> AsciiBase64Url)
-> (SearchAfterKey -> ByteString)
-> SearchAfterKey
-> AsciiBase64Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (SearchAfterKey -> ByteString) -> SearchAfterKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchAfterKey -> ByteString
forall a. ToJSON a => a -> ByteString
encode

    mkResult :: SearchResult UserDoc -> SearchResult UserDoc
mkResult SearchResult UserDoc
es =
      let hitsPlusOne :: [Hit UserDoc]
hitsPlusOne = SearchHits UserDoc -> [Hit UserDoc]
forall a. SearchHits a -> [Hit a]
ES.hits (SearchHits UserDoc -> [Hit UserDoc])
-> (SearchResult UserDoc -> SearchHits UserDoc)
-> SearchResult UserDoc
-> [Hit UserDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchResult UserDoc -> SearchHits UserDoc
forall a. SearchResult a -> SearchHits a
ES.searchHits (SearchResult UserDoc -> [Hit UserDoc])
-> SearchResult UserDoc -> [Hit UserDoc]
forall a b. (a -> b) -> a -> b
$ SearchResult UserDoc
es
          hits :: [Hit UserDoc]
hits = Int -> [Hit UserDoc] -> [Hit UserDoc]
forall a. Int -> [a] -> [a]
take (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxResults) [Hit UserDoc]
hitsPlusOne
          mps :: Maybe PagingState
mps = SearchAfterKey -> PagingState
fromSearchAfterKey (SearchAfterKey -> PagingState)
-> Maybe SearchAfterKey -> Maybe PagingState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SearchAfterKey] -> Maybe SearchAfterKey
forall a. [a] -> Maybe a
lastMay ((Hit UserDoc -> Maybe SearchAfterKey)
-> [Hit UserDoc] -> [SearchAfterKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Hit UserDoc -> Maybe SearchAfterKey
forall a. Hit a -> Maybe SearchAfterKey
ES.hitSort [Hit UserDoc]
hits)
          results :: [UserDoc]
results = (Hit UserDoc -> Maybe UserDoc) -> [Hit UserDoc] -> [UserDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Hit UserDoc -> Maybe UserDoc
forall a. Hit a -> Maybe a
ES.hitSource [Hit UserDoc]
hits
       in SearchResult
            { $sel:searchFound:SearchResult :: Int
searchFound = SearchHits UserDoc -> Int
forall a. SearchHits a -> Int
ES.hitsTotal (SearchHits UserDoc -> Int)
-> (SearchResult UserDoc -> SearchHits UserDoc)
-> SearchResult UserDoc
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchResult UserDoc -> SearchHits UserDoc
forall a. SearchResult a -> SearchHits a
ES.searchHits (SearchResult UserDoc -> Int) -> SearchResult UserDoc -> Int
forall a b. (a -> b) -> a -> b
$ SearchResult UserDoc
es,
              $sel:searchReturned:SearchResult :: Int
searchReturned = [UserDoc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UserDoc]
results,
              $sel:searchTook:SearchResult :: Int
searchTook = SearchResult UserDoc -> Int
forall a. SearchResult a -> Int
ES.took SearchResult UserDoc
es,
              $sel:searchResults:SearchResult :: [UserDoc]
searchResults = [UserDoc]
results,
              $sel:searchPolicy:SearchResult :: FederatedUserSearchPolicy
searchPolicy = FederatedUserSearchPolicy
FullSearch,
              $sel:searchPagingState:SearchResult :: Maybe PagingState
searchPagingState = Maybe PagingState
mps,
              $sel:searchHasMore:SearchResult :: Maybe Bool
searchHasMore = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ [Hit UserDoc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hit UserDoc]
hitsPlusOne Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Hit UserDoc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hit UserDoc]
hits
            }

searchInMainIndex :: forall r. (Member (Embed IO) r) => IndexedUserStoreConfig -> ES.Search -> Sem r (ES.SearchResult UserDoc)
searchInMainIndex :: forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig -> Search -> Sem r (SearchResult UserDoc)
searchInMainIndex IndexedUserStoreConfig
cfg Search
search = do
  Either EsError (SearchResult UserDoc)
r <- BHEnv
-> BH (Sem r) (Either EsError (SearchResult UserDoc))
-> Sem r (Either EsError (SearchResult UserDoc))
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH IndexedUserStoreConfig
cfg.conn.env (BH (Sem r) (Either EsError (SearchResult UserDoc))
 -> Sem r (Either EsError (SearchResult UserDoc)))
-> BH (Sem r) (Either EsError (SearchResult UserDoc))
-> Sem r (Either EsError (SearchResult UserDoc))
forall a b. (a -> b) -> a -> b
$ do
    Reply
res <- IndexName -> MappingName -> Search -> BH (Sem r) Reply
forall (m :: * -> *).
MonadBH m =>
IndexName -> MappingName -> Search -> m Reply
ES.searchByType IndexedUserStoreConfig
cfg.conn.indexName MappingName
mappingName Search
search
    IO (Either EsError (SearchResult UserDoc))
-> BH (Sem r) (Either EsError (SearchResult UserDoc))
forall a. IO a -> BH (Sem r) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either EsError (SearchResult UserDoc))
 -> BH (Sem r) (Either EsError (SearchResult UserDoc)))
-> IO (Either EsError (SearchResult UserDoc))
-> BH (Sem r) (Either EsError (SearchResult UserDoc))
forall a b. (a -> b) -> a -> b
$ Reply -> IO (Either EsError (SearchResult UserDoc))
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Reply -> m (Either EsError a)
ES.parseEsResponse Reply
res
  (EsError -> Sem r (SearchResult UserDoc))
-> (SearchResult UserDoc -> Sem r (SearchResult UserDoc))
-> Either EsError (SearchResult UserDoc)
-> Sem r (SearchResult UserDoc)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO (SearchResult UserDoc) -> Sem r (SearchResult UserDoc)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (SearchResult UserDoc) -> Sem r (SearchResult UserDoc))
-> (EsError -> IO (SearchResult UserDoc))
-> EsError
-> Sem r (SearchResult UserDoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexedUserStoreError -> IO (SearchResult UserDoc)
forall e a. Exception e => e -> IO a
throwIO (IndexedUserStoreError -> IO (SearchResult UserDoc))
-> (EsError -> IndexedUserStoreError)
-> EsError
-> IO (SearchResult UserDoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EsError -> IndexedUserStoreError
IndexLookupError) SearchResult UserDoc -> Sem r (SearchResult UserDoc)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either EsError (SearchResult UserDoc)
r

queryIndex ::
  (Member (Embed IO) r) =>
  IndexedUserStoreConfig ->
  Int ->
  IndexQuery x ->
  Sem r (SearchResult UserDoc)
queryIndex :: forall {k} (r :: EffectRow) (x :: k).
Member (Embed IO) r =>
IndexedUserStoreConfig
-> Int -> IndexQuery x -> Sem r (SearchResult UserDoc)
queryIndex IndexedUserStoreConfig
cfg Int
s (IndexQuery Query
q Filter
f [DefaultSort]
_) = do
  let search :: Search
search = (Maybe Query -> Maybe Filter -> Search
ES.mkSearch (Query -> Maybe Query
forall a. a -> Maybe a
Just Query
q) (Filter -> Maybe Filter
forall a. a -> Maybe a
Just Filter
f)) {ES.size = ES.Size (fromIntegral s)}
  SearchResult UserDoc -> SearchResult UserDoc
forall {a}. SearchResult a -> SearchResult a
mkResult (SearchResult UserDoc -> SearchResult UserDoc)
-> Sem r (SearchResult UserDoc) -> Sem r (SearchResult UserDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IndexedUserStoreConfig -> Search -> Sem r (SearchResult UserDoc)
forall (r :: EffectRow).
Member (Embed IO) r =>
IndexedUserStoreConfig -> Search -> Sem r (SearchResult UserDoc)
searchInMainIndex IndexedUserStoreConfig
cfg Search
search
  where
    mkResult :: SearchResult a -> SearchResult a
mkResult SearchResult a
es =
      let results :: [a]
results = (Hit a -> Maybe a) -> [Hit a] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Hit a -> Maybe a
forall a. Hit a -> Maybe a
ES.hitSource ([Hit a] -> [a])
-> (SearchResult a -> [Hit a]) -> SearchResult a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchHits a -> [Hit a]
forall a. SearchHits a -> [Hit a]
ES.hits (SearchHits a -> [Hit a])
-> (SearchResult a -> SearchHits a) -> SearchResult a -> [Hit a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchResult a -> SearchHits a
forall a. SearchResult a -> SearchHits a
ES.searchHits (SearchResult a -> [a]) -> SearchResult a -> [a]
forall a b. (a -> b) -> a -> b
$ SearchResult a
es
       in SearchResult
            { $sel:searchFound:SearchResult :: Int
searchFound = SearchHits a -> Int
forall a. SearchHits a -> Int
ES.hitsTotal (SearchHits a -> Int)
-> (SearchResult a -> SearchHits a) -> SearchResult a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchResult a -> SearchHits a
forall a. SearchResult a -> SearchHits a
ES.searchHits (SearchResult a -> Int) -> SearchResult a -> Int
forall a b. (a -> b) -> a -> b
$ SearchResult a
es,
              $sel:searchReturned:SearchResult :: Int
searchReturned = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
results,
              $sel:searchTook:SearchResult :: Int
searchTook = SearchResult a -> Int
forall a. SearchResult a -> Int
ES.took SearchResult a
es,
              $sel:searchResults:SearchResult :: [a]
searchResults = [a]
results,
              $sel:searchPolicy:SearchResult :: FederatedUserSearchPolicy
searchPolicy = FederatedUserSearchPolicy
FullSearch,
              $sel:searchPagingState:SearchResult :: Maybe PagingState
searchPagingState = Maybe PagingState
forall a. Maybe a
Nothing,
              $sel:searchHasMore:SearchResult :: Maybe Bool
searchHasMore = Maybe Bool
forall a. Maybe a
Nothing
            }

teamUserSearchQuery ::
  TeamId ->
  Maybe Text ->
  Maybe RoleFilter ->
  Maybe TeamUserSearchSortBy ->
  Maybe TeamUserSearchSortOrder ->
  IndexQuery TeamContact
teamUserSearchQuery :: TeamId
-> Maybe Text
-> Maybe RoleFilter
-> Maybe TeamUserSearchSortBy
-> Maybe TeamUserSearchSortOrder
-> IndexQuery TeamContact
teamUserSearchQuery TeamId
tid Maybe Text
mbSearchText Maybe RoleFilter
_mRoleFilter Maybe TeamUserSearchSortBy
mSortBy Maybe TeamUserSearchSortOrder
mSortOrder =
  Query -> Filter -> [DefaultSort] -> IndexQuery TeamContact
forall {k} (r :: k).
Query -> Filter -> [DefaultSort] -> IndexQuery r
IndexQuery
    ( Query -> (Text -> Query) -> Maybe Text -> Query
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Maybe Boost -> Query
ES.MatchAllQuery Maybe Boost
forall a. Maybe a
Nothing)
        Text -> Query
matchPhraseOrPrefix
        Maybe Text
mbQStr
    )
    Filter
teamFilter
    -- in combination with pagination a non-unique search specification can lead to missing results
    -- therefore we use the unique `_doc` value as a tie breaker
    -- - see https://www.elastic.co/guide/en/elasticsearch/reference/6.8/search-request-sort.html for details on `_doc`
    -- - see https://www.elastic.co/guide/en/elasticsearch/reference/6.8/search-request-search-after.html for details on pagination and tie breaker
    -- in the latter article it "is advised to duplicate (client side or [...]) the content of the _id field
    -- in another field that has doc value enabled and to use this new field as the tiebreaker for the sort"
    -- so alternatively we could use the user ID as a tie breaker, but this would require a change in the index mapping
    ([DefaultSort]
sorting [DefaultSort] -> [DefaultSort] -> [DefaultSort]
forall a. [a] -> [a] -> [a]
++ [DefaultSort]
sortingTieBreaker)
  where
    sorting :: [ES.DefaultSort]
    sorting :: [DefaultSort]
sorting =
      [DefaultSort]
-> (TeamUserSearchSortBy -> [DefaultSort])
-> Maybe TeamUserSearchSortBy
-> [DefaultSort]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        [TeamUserSearchSortBy -> TeamUserSearchSortOrder -> DefaultSort
defaultSort TeamUserSearchSortBy
SortByCreatedAt TeamUserSearchSortOrder
SortOrderDesc | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
mbQStr]
        (\TeamUserSearchSortBy
tuSortBy -> [TeamUserSearchSortBy -> TeamUserSearchSortOrder -> DefaultSort
defaultSort TeamUserSearchSortBy
tuSortBy (TeamUserSearchSortOrder
-> Maybe TeamUserSearchSortOrder -> TeamUserSearchSortOrder
forall a. a -> Maybe a -> a
fromMaybe TeamUserSearchSortOrder
SortOrderAsc Maybe TeamUserSearchSortOrder
mSortOrder)])
        Maybe TeamUserSearchSortBy
mSortBy
    sortingTieBreaker :: [ES.DefaultSort]
    sortingTieBreaker :: [DefaultSort]
sortingTieBreaker = [FieldName
-> SortOrder
-> Maybe Text
-> Maybe SortMode
-> Maybe Missing
-> Maybe Filter
-> DefaultSort
ES.DefaultSort (Text -> FieldName
ES.FieldName Text
"_doc") SortOrder
ES.Ascending Maybe Text
forall a. Maybe a
Nothing Maybe SortMode
forall a. Maybe a
Nothing Maybe Missing
forall a. Maybe a
Nothing Maybe Filter
forall a. Maybe a
Nothing]

    mbQStr :: Maybe Text
    mbQStr :: Maybe Text
mbQStr =
      case Maybe Text
mbSearchText of
        Maybe Text
Nothing -> Maybe Text
forall a. Maybe a
Nothing
        Just Text
q ->
          case Text -> Text
normalized Text
q of
            Text
"" -> Maybe Text
forall a. Maybe a
Nothing
            Text
term' -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
term'

    matchPhraseOrPrefix :: Text -> Query
matchPhraseOrPrefix Text
term' =
      MultiMatchQuery -> Query
ES.QueryMultiMatchQuery (MultiMatchQuery -> Query) -> MultiMatchQuery -> Query
forall a b. (a -> b) -> a -> b
$
        ( [FieldName] -> QueryString -> MultiMatchQuery
ES.mkMultiMatchQuery
            [ Text -> FieldName
ES.FieldName Text
"email^4",
              Text -> FieldName
ES.FieldName Text
"handle^4",
              Text -> FieldName
ES.FieldName Text
"normalized^3",
              Text -> FieldName
ES.FieldName Text
"email.prefix^3",
              Text -> FieldName
ES.FieldName Text
"handle.prefix^2",
              Text -> FieldName
ES.FieldName Text
"normalized.prefix"
            ]
            (Text -> QueryString
ES.QueryString Text
term')
        )
          { ES.multiMatchQueryType = Just ES.MultiMatchMostFields,
            ES.multiMatchQueryOperator = ES.And
          }

    teamFilter :: Filter
teamFilter =
      Query -> Filter
ES.Filter (Query -> Filter) -> Query -> Filter
forall a b. (a -> b) -> a -> b
$
        BoolQuery -> Query
ES.QueryBoolQuery
          BoolQuery
boolQuery
            { ES.boolQueryMustMatch = [ES.TermQuery (ES.Term "team" $ idToText tid) Nothing]
            }

    defaultSort :: TeamUserSearchSortBy -> TeamUserSearchSortOrder -> ES.DefaultSort
    defaultSort :: TeamUserSearchSortBy -> TeamUserSearchSortOrder -> DefaultSort
defaultSort TeamUserSearchSortBy
tuSortBy TeamUserSearchSortOrder
sortOrder =
      FieldName
-> SortOrder
-> Maybe Text
-> Maybe SortMode
-> Maybe Missing
-> Maybe Filter
-> DefaultSort
ES.DefaultSort
        ( case TeamUserSearchSortBy
tuSortBy of
            TeamUserSearchSortBy
SortByName -> Text -> FieldName
ES.FieldName Text
"name"
            TeamUserSearchSortBy
SortByHandle -> Text -> FieldName
ES.FieldName Text
"handle.keyword"
            TeamUserSearchSortBy
SortByEmail -> Text -> FieldName
ES.FieldName Text
"email.keyword"
            TeamUserSearchSortBy
SortBySAMLIdp -> Text -> FieldName
ES.FieldName Text
"saml_idp"
            TeamUserSearchSortBy
SortByManagedBy -> Text -> FieldName
ES.FieldName Text
"managed_by"
            TeamUserSearchSortBy
SortByRole -> Text -> FieldName
ES.FieldName Text
"role"
            TeamUserSearchSortBy
SortByCreatedAt -> Text -> FieldName
ES.FieldName Text
"created_at"
        )
        ( case TeamUserSearchSortOrder
sortOrder of
            TeamUserSearchSortOrder
SortOrderAsc -> SortOrder
ES.Ascending
            TeamUserSearchSortOrder
SortOrderDesc -> SortOrder
ES.Descending
        )
        Maybe Text
forall a. Maybe a
Nothing
        Maybe SortMode
forall a. Maybe a
Nothing
        Maybe Missing
forall a. Maybe a
Nothing
        Maybe Filter
forall a. Maybe a
Nothing

mkUserQuery :: UserId -> Maybe TeamId -> TeamSearchInfo -> ES.Query -> IndexQuery Contact
mkUserQuery :: UserId
-> Maybe TeamId -> TeamSearchInfo -> Query -> IndexQuery Contact
mkUserQuery UserId
searcher Maybe TeamId
mSearcherTeamId TeamSearchInfo
teamSearchInfo Query
q =
  Query -> Filter -> [DefaultSort] -> IndexQuery Contact
forall {k} (r :: k).
Query -> Filter -> [DefaultSort] -> IndexQuery r
IndexQuery
    Query
q
    ( Query -> Filter
ES.Filter
        (Query -> Filter) -> (BoolQuery -> Query) -> BoolQuery -> Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoolQuery -> Query
ES.QueryBoolQuery
        (BoolQuery -> Filter) -> BoolQuery -> Filter
forall a b. (a -> b) -> a -> b
$ BoolQuery
boolQuery
          { ES.boolQueryMustNotMatch = maybeToList $ matchSelf searcher,
            ES.boolQueryMustMatch =
              [ restrictSearchSpace mSearcherTeamId teamSearchInfo,
                ES.QueryBoolQuery
                  boolQuery
                    { ES.boolQueryShouldMatch =
                        [ termQ "account_status" "active",
                          -- Also match entries where the account_status field is not present.
                          -- These must have been inserted before we added the account_status
                          -- and at that time we only inserted active users in the first place.
                          -- This should be unnecessary after re-indexing, but let's be lenient
                          -- here for a while.
                          ES.QueryBoolQuery
                            boolQuery
                              { ES.boolQueryMustNotMatch =
                                  [ES.QueryExistsQuery (ES.FieldName "account_status")]
                              }
                        ]
                    }
              ]
          }
    )
    []

termQ :: Text -> Text -> ES.Query
termQ :: Text -> Text -> Query
termQ Text
f Text
v =
  Term -> Maybe Boost -> Query
ES.TermQuery
    ES.Term
      { termField :: Text
ES.termField = Text
f,
        termValue :: Text
ES.termValue = Text
v
      }
    Maybe Boost
forall a. Maybe a
Nothing

matchSelf :: UserId -> Maybe ES.Query
matchSelf :: UserId -> Maybe Query
matchSelf UserId
searcher = Query -> Maybe Query
forall a. a -> Maybe a
Just (Text -> Text -> Query
termQ Text
"_id" (UserId -> Text
forall {k} (a :: k). Id a -> Text
idToText UserId
searcher))

-- | See 'TeamSearchInfo'
restrictSearchSpace :: Maybe TeamId -> TeamSearchInfo -> ES.Query
-- restrictSearchSpace (FederatedSearch Nothing) =
--   ES.QueryBoolQuery
--     boolQuery
--       { ES.boolQueryShouldMatch =
--           [ matchNonTeamMemberUsers,
--             matchTeamMembersSearchableByAllTeams
--           ]
--       }
-- restrictSearchSpace (FederatedSearch (Just [])) =
--   ES.QueryBoolQuery
--     boolQuery
--       { ES.boolQueryMustMatch =
--           [ -- if the list of allowed teams is empty, this is impossible to fulfill, and no results will be returned
--             -- this case should be handled earlier, so this is just a safety net
--             ES.TermQuery (ES.Term "team" "must not match any team") Nothing
--           ]
--       }
-- restrictSearchSpace (FederatedSearch (Just teams)) =
--   ES.QueryBoolQuery
--     boolQuery
--       { ES.boolQueryMustMatch =
--           [ matchTeamMembersSearchableByAllTeams,
--             onlyInTeams
--           ]
--       }
--   where
--     onlyInTeams = ES.QueryBoolQuery boolQuery {ES.boolQueryShouldMatch = map matchTeamMembersOf teams}
restrictSearchSpace :: Maybe TeamId -> TeamSearchInfo -> Query
restrictSearchSpace Maybe TeamId
mteam TeamSearchInfo
searchInfo =
  case (Maybe TeamId
mteam, TeamSearchInfo
searchInfo) of
    (Maybe TeamId
Nothing, TeamSearchInfo
_) -> Query
matchNonTeamMemberUsers
    (Just TeamId
_, TeamSearchInfo
NoTeam) -> Query
matchNonTeamMemberUsers
    (Just TeamId
searcherTeam, TeamOnly TeamId
team) ->
      if TeamId
searcherTeam TeamId -> TeamId -> Bool
forall a. Eq a => a -> a -> Bool
== TeamId
team
        then TeamId -> Query
matchTeamMembersOf TeamId
team
        else Query
ES.QueryMatchNoneQuery
    (Just TeamId
searcherTeam, TeamSearchInfo
AllUsers) ->
      BoolQuery -> Query
ES.QueryBoolQuery
        BoolQuery
boolQuery
          { ES.boolQueryShouldMatch =
              [ matchNonTeamMemberUsers,
                matchTeamMembersSearchableByAllTeams,
                matchTeamMembersOf searcherTeam
              ]
          }

matchTeamMembersOf :: TeamId -> ES.Query
matchTeamMembersOf :: TeamId -> Query
matchTeamMembersOf TeamId
team = Term -> Maybe Boost -> Query
ES.TermQuery (Text -> Text -> Term
ES.Term Text
"team" (Text -> Term) -> Text -> Term
forall a b. (a -> b) -> a -> b
$ TeamId -> Text
forall {k} (a :: k). Id a -> Text
idToText TeamId
team) Maybe Boost
forall a. Maybe a
Nothing

matchTeamMembersSearchableByAllTeams :: ES.Query
matchTeamMembersSearchableByAllTeams :: Query
matchTeamMembersSearchableByAllTeams =
  BoolQuery -> Query
ES.QueryBoolQuery
    BoolQuery
boolQuery
      { ES.boolQueryMustMatch =
          [ ES.QueryExistsQuery $ ES.FieldName "team",
            ES.TermQuery (ES.Term (Key.toText searchVisibilityInboundFieldName) "searchable-by-all-teams") Nothing
          ]
      }

matchNonTeamMemberUsers :: ES.Query
matchNonTeamMemberUsers :: Query
matchNonTeamMemberUsers =
  BoolQuery -> Query
ES.QueryBoolQuery
    BoolQuery
boolQuery
      { ES.boolQueryMustNotMatch = [ES.QueryExistsQuery $ ES.FieldName "team"]
      }

matchUsersNotInTeam :: TeamId -> ES.Query
matchUsersNotInTeam :: TeamId -> Query
matchUsersNotInTeam TeamId
tid =
  BoolQuery -> Query
ES.QueryBoolQuery
    BoolQuery
boolQuery
      { ES.boolQueryMustNotMatch = [ES.TermQuery (ES.Term "team" $ idToText tid) Nothing]
      }

--------------------------------------------
-- Utils

runInBothES :: (Monad m) => IndexedUserStoreConfig -> (ES.IndexName -> ES.BH m a) -> m (a, Maybe a)
runInBothES :: forall (m :: * -> *) a.
Monad m =>
IndexedUserStoreConfig -> (IndexName -> BH m a) -> m (a, Maybe a)
runInBothES IndexedUserStoreConfig
cfg IndexName -> BH m a
f = do
  a
x <- BHEnv -> BH m a -> m a
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH IndexedUserStoreConfig
cfg.conn.env (BH m a -> m a) -> BH m a -> m a
forall a b. (a -> b) -> a -> b
$ IndexName -> BH m a
f IndexedUserStoreConfig
cfg.conn.indexName
  Maybe a
y <- Maybe ESConn -> (ESConn -> m a) -> m (Maybe a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM IndexedUserStoreConfig
cfg.additionalConn ((ESConn -> m a) -> m (Maybe a)) -> (ESConn -> m a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \ESConn
additional ->
    BHEnv -> BH m a -> m a
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH ESConn
additional.env (BH m a -> m a) -> BH m a -> m a
forall a b. (a -> b) -> a -> b
$ IndexName -> BH m a
f ESConn
additional.indexName
  (a, Maybe a) -> m (a, Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, Maybe a
y)

mappingName :: ES.MappingName
mappingName :: MappingName
mappingName = Text -> MappingName
ES.MappingName Text
"user"

boolQuery :: ES.BoolQuery
boolQuery :: BoolQuery
boolQuery = [Query] -> [Filter] -> [Query] -> [Query] -> BoolQuery
ES.mkBoolQuery [] [] [] []