module Wire.IndexedUserStore.MigrationStore.ElasticSearch where

import Data.Aeson
import Data.Text qualified as Text
import Database.Bloodhound qualified as ES
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.TinyLog
import System.Logger.Message qualified as Log
import Wire.IndexedUserStore.MigrationStore
import Wire.Sem.Logger qualified as Log
import Wire.UserSearch.Migration

interpretIndexedUserMigrationStoreES :: (Member (Embed IO) r, Member (Error MigrationException) r, Member TinyLog r) => ES.BHEnv -> InterpreterFor IndexedUserMigrationStore r
interpretIndexedUserMigrationStoreES :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error MigrationException) r,
 Member TinyLog r) =>
BHEnv -> InterpreterFor IndexedUserMigrationStore r
interpretIndexedUserMigrationStoreES BHEnv
env = (forall (rInitial :: EffectRow) x.
 IndexedUserMigrationStore (Sem rInitial) x -> Sem r x)
-> Sem (IndexedUserMigrationStore : 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.
  IndexedUserMigrationStore (Sem rInitial) x -> Sem r x)
 -> Sem (IndexedUserMigrationStore : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    IndexedUserMigrationStore (Sem rInitial) x -> Sem r x)
-> Sem (IndexedUserMigrationStore : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  IndexedUserMigrationStore (Sem rInitial) x
EnsureMigrationIndex -> BHEnv -> Sem r ()
forall (r :: EffectRow).
(Member TinyLog r, Member (Embed IO) r,
 Member (Error MigrationException) r) =>
BHEnv -> Sem r ()
ensureMigrationIndexImpl BHEnv
env
  IndexedUserMigrationStore (Sem rInitial) x
GetLatestMigrationVersion -> BHEnv -> Sem r MigrationVersion
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error MigrationException) r) =>
BHEnv -> Sem r MigrationVersion
getLatestMigrationVersionImpl BHEnv
env
  PersistMigrationVersion MigrationVersion
v -> BHEnv -> MigrationVersion -> Sem r ()
forall (r :: EffectRow).
(Member (Embed IO) r, Member TinyLog r,
 Member (Error MigrationException) r) =>
BHEnv -> MigrationVersion -> Sem r ()
persistMigrationVersionImpl BHEnv
env MigrationVersion
v

ensureMigrationIndexImpl :: (Member TinyLog r, Member (Embed IO) r, Member (Error MigrationException) r) => ES.BHEnv -> Sem r ()
ensureMigrationIndexImpl :: forall (r :: EffectRow).
(Member TinyLog r, Member (Embed IO) r,
 Member (Error MigrationException) r) =>
BHEnv -> Sem r ()
ensureMigrationIndexImpl BHEnv
env = do
  Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (BHEnv -> BH (Sem r) Bool -> Sem r Bool
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH BHEnv
env (BH (Sem r) Bool -> Sem r Bool) -> BH (Sem r) Bool -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ IndexName -> BH (Sem r) Bool
forall (m :: * -> *). MonadBH m => IndexName -> m Bool
ES.indexExists IndexName
migrationIndexName) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.info ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
      Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (ByteString -> Builder
Log.val ByteString
"Creating migrations index, used for tracking which migrations have run")
    BHEnv -> BH (Sem r) Reply -> Sem r Reply
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH BHEnv
env ([UpdatableIndexSetting] -> Int -> IndexName -> BH (Sem r) Reply
forall (m :: * -> *).
MonadBH m =>
[UpdatableIndexSetting] -> Int -> IndexName -> m Reply
ES.createIndexWith [] Int
1 IndexName
migrationIndexName)
      Sem r Reply -> (Reply -> Sem r ()) -> Sem r ()
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> MigrationException) -> Reply -> Sem r ()
forall {e} {r :: EffectRow}.
Member (Error e) r =>
(String -> e) -> Reply -> Sem r ()
throwIfNotCreated String -> MigrationException
CreateMigrationIndexFailed
  BHEnv -> BH (Sem r) Reply -> Sem r Reply
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH BHEnv
env (IndexName -> MappingName -> Value -> BH (Sem r) Reply
forall (m :: * -> *) a.
(MonadBH m, ToJSON a) =>
IndexName -> MappingName -> a -> m Reply
ES.putMapping IndexName
migrationIndexName MappingName
migrationMappingName Value
migrationIndexMapping)
    Sem r Reply -> (Reply -> Sem r ()) -> Sem r ()
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> MigrationException) -> Reply -> Sem r ()
forall {e} {r :: EffectRow}.
Member (Error e) r =>
(String -> e) -> Reply -> Sem r ()
throwIfNotCreated String -> MigrationException
PutMappingFailed
  where
    throwIfNotCreated :: (String -> e) -> Reply -> Sem r ()
throwIfNotCreated String -> e
mkErr Reply
response =
      Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Reply -> Bool
ES.isSuccess Reply
response) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        e -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (e -> Sem r ()) -> e -> Sem r ()
forall a b. (a -> b) -> a -> b
$
          String -> e
mkErr (Reply -> String
forall a. Show a => a -> String
show Reply
response)

getLatestMigrationVersionImpl :: (Member (Embed IO) r, Member (Error MigrationException) r) => ES.BHEnv -> Sem r MigrationVersion
getLatestMigrationVersionImpl :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error MigrationException) r) =>
BHEnv -> Sem r MigrationVersion
getLatestMigrationVersionImpl BHEnv
env = do
  Reply
reply <- BHEnv -> BH (Sem r) Reply -> Sem r Reply
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH BHEnv
env (BH (Sem r) Reply -> Sem r Reply)
-> BH (Sem r) Reply -> Sem r Reply
forall a b. (a -> b) -> a -> b
$ IndexName -> Search -> BH (Sem r) Reply
forall (m :: * -> *). MonadBH m => IndexName -> Search -> m Reply
ES.searchByIndex IndexName
migrationIndexName (Maybe Query -> Maybe Filter -> Search
ES.mkSearch Maybe Query
forall a. Maybe a
Nothing Maybe Filter
forall a. Maybe a
Nothing)
  Either EsError (SearchResult MigrationVersion)
resp <- IO (Either EsError (SearchResult MigrationVersion))
-> Sem r (Either EsError (SearchResult MigrationVersion))
forall a. IO a -> Sem r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either EsError (SearchResult MigrationVersion))
 -> Sem r (Either EsError (SearchResult MigrationVersion)))
-> IO (Either EsError (SearchResult MigrationVersion))
-> Sem r (Either EsError (SearchResult MigrationVersion))
forall a b. (a -> b) -> a -> b
$ Reply -> IO (Either EsError (SearchResult MigrationVersion))
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Reply -> m (Either EsError a)
ES.parseEsResponse Reply
reply
  SearchResult MigrationVersion
result <- (EsError -> Sem r (SearchResult MigrationVersion))
-> (SearchResult MigrationVersion
    -> Sem r (SearchResult MigrationVersion))
-> Either EsError (SearchResult MigrationVersion)
-> Sem r (SearchResult MigrationVersion)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MigrationException -> Sem r (SearchResult MigrationVersion)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MigrationException -> Sem r (SearchResult MigrationVersion))
-> (EsError -> MigrationException)
-> EsError
-> Sem r (SearchResult MigrationVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MigrationException
FetchMigrationVersionsFailed (String -> MigrationException)
-> (EsError -> String) -> EsError -> MigrationException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EsError -> String
forall a. Show a => a -> String
show) SearchResult MigrationVersion
-> Sem r (SearchResult MigrationVersion)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either EsError (SearchResult MigrationVersion)
resp
  let versions :: [Maybe MigrationVersion]
versions = (Hit MigrationVersion -> Maybe MigrationVersion)
-> [Hit MigrationVersion] -> [Maybe MigrationVersion]
forall a b. (a -> b) -> [a] -> [b]
map Hit MigrationVersion -> Maybe MigrationVersion
forall a. Hit a -> Maybe a
ES.hitSource ([Hit MigrationVersion] -> [Maybe MigrationVersion])
-> [Hit MigrationVersion] -> [Maybe MigrationVersion]
forall a b. (a -> b) -> a -> b
$ SearchHits MigrationVersion -> [Hit MigrationVersion]
forall a. SearchHits a -> [Hit a]
ES.hits (SearchHits MigrationVersion -> [Hit MigrationVersion])
-> (SearchResult MigrationVersion -> SearchHits MigrationVersion)
-> SearchResult MigrationVersion
-> [Hit MigrationVersion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchResult MigrationVersion -> SearchHits MigrationVersion
forall a. SearchResult a -> SearchHits a
ES.searchHits (SearchResult MigrationVersion -> [Hit MigrationVersion])
-> SearchResult MigrationVersion -> [Hit MigrationVersion]
forall a b. (a -> b) -> a -> b
$ SearchResult MigrationVersion
result
  case [Maybe MigrationVersion]
versions of
    [] ->
      MigrationVersion -> Sem r MigrationVersion
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MigrationVersion -> Sem r MigrationVersion)
-> MigrationVersion -> Sem r MigrationVersion
forall a b. (a -> b) -> a -> b
$ Natural -> MigrationVersion
MigrationVersion Natural
0
    [Maybe MigrationVersion]
vs ->
      if (Maybe MigrationVersion -> Bool)
-> [Maybe MigrationVersion] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe MigrationVersion -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe MigrationVersion]
vs
        then MigrationException -> Sem r MigrationVersion
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MigrationException -> Sem r MigrationVersion)
-> MigrationException -> Sem r MigrationVersion
forall a b. (a -> b) -> a -> b
$ SearchResult MigrationVersion -> MigrationException
VersionSourceMissing SearchResult MigrationVersion
result
        else MigrationVersion -> Sem r MigrationVersion
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MigrationVersion -> Sem r MigrationVersion)
-> MigrationVersion -> Sem r MigrationVersion
forall a b. (a -> b) -> a -> b
$ [MigrationVersion] -> MigrationVersion
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([MigrationVersion] -> MigrationVersion)
-> [MigrationVersion] -> MigrationVersion
forall a b. (a -> b) -> a -> b
$ [Maybe MigrationVersion] -> [MigrationVersion]
forall a. [Maybe a] -> [a]
catMaybes [Maybe MigrationVersion]
vs

persistMigrationVersionImpl :: (Member (Embed IO) r, Member TinyLog r, Member (Error MigrationException) r) => ES.BHEnv -> MigrationVersion -> Sem r ()
persistMigrationVersionImpl :: forall (r :: EffectRow).
(Member (Embed IO) r, Member TinyLog r,
 Member (Error MigrationException) r) =>
BHEnv -> MigrationVersion -> Sem r ()
persistMigrationVersionImpl BHEnv
env MigrationVersion
v = do
  let docId :: DocId
docId = Text -> DocId
ES.DocId (Text -> DocId) -> (Natural -> Text) -> Natural -> DocId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (Natural -> String) -> Natural -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> String
forall a. Show a => a -> String
show (Natural -> DocId) -> Natural -> DocId
forall a b. (a -> b) -> a -> b
$ MigrationVersion -> Natural
migrationVersion MigrationVersion
v
  Reply
persistResponse <- BHEnv -> BH (Sem r) Reply -> Sem r Reply
forall (m :: * -> *) a. BHEnv -> BH m a -> m a
ES.runBH BHEnv
env (BH (Sem r) Reply -> Sem r Reply)
-> BH (Sem r) Reply -> Sem r Reply
forall a b. (a -> b) -> a -> b
$ IndexName
-> MappingName
-> IndexDocumentSettings
-> MigrationVersion
-> DocId
-> BH (Sem r) Reply
forall doc (m :: * -> *).
(ToJSON doc, MonadBH m) =>
IndexName
-> MappingName -> IndexDocumentSettings -> doc -> DocId -> m Reply
ES.indexDocument IndexName
migrationIndexName MappingName
migrationMappingName IndexDocumentSettings
ES.defaultIndexDocumentSettings MigrationVersion
v DocId
docId
  if Reply -> Bool
ES.isCreated Reply
persistResponse
    then do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.info ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (ByteString -> Builder
Log.val ByteString
"Migration success recorded")
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> MigrationVersion -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"migrationVersion" MigrationVersion
v
    else MigrationException -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MigrationException -> Sem r ()) -> MigrationException -> Sem r ()
forall a b. (a -> b) -> a -> b
$ MigrationVersion -> String -> MigrationException
PersistVersionFailed MigrationVersion
v (String -> MigrationException) -> String -> MigrationException
forall a b. (a -> b) -> a -> b
$ Reply -> String
forall a. Show a => a -> String
show Reply
persistResponse

migrationIndexName :: ES.IndexName
migrationIndexName :: IndexName
migrationIndexName = Text -> IndexName
ES.IndexName Text
"wire_brig_migrations"

migrationMappingName :: ES.MappingName
migrationMappingName :: MappingName
migrationMappingName = Text -> MappingName
ES.MappingName Text
"wire_brig_migrations"

migrationIndexMapping :: Value
migrationIndexMapping :: Value
migrationIndexMapping =
  [Pair] -> Value
object
    [ Key
"properties"
        Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [Pair] -> Value
object
          [Key
"migration_version" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [Pair] -> Value
object [Key
"index" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Bool
True, Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"integer" :: Text)]]
    ]