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)]] ]