diff --git a/CHANGELOG.md b/CHANGELOG.md index 14c1c55d8..cd4b377b3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,10 @@ All notable changes to this project will be documented in this file. ### Changed +- [api] The API no longer dumps large decoding error to the stdout. + Exceptions from the elastic API are now intercepted and displayed in a nicer format. + In a future change, such errors will be indexed for proper debugging. + ### Removed ### Fixed diff --git a/src/CLI.hs b/src/CLI.hs index a65049353..d170a9cac 100644 --- a/src/CLI.hs +++ b/src/CLI.hs @@ -152,7 +152,7 @@ usageJanitor = (eitherReader $ (first T.unpack . Config.mkIndexName) . T.pack) (long "workspace" <> O.help "Workspace name" <> metavar "WORKSPACE") crawlerNameOption = strOption (long "crawler-name" <> O.help "The crawler name" <> metavar "CRAWLER_NAME") - runOnWorkspace env action' workspace = runEff $ runLoggerEffect $ runElasticEffect env $ runEmptyQueryM workspace action' + runOnWorkspace env action' workspace = runEff $ runLoggerEffect $ runElasticEffect env $ runEmptyQueryM workspace $ dieOnEsError action' noWorkspace workspaceName = "Unable to find the workspace " <> Config.getIndexName workspaceName <> " in the Monocle config" janitorUpdateIdent = io <$> parser where diff --git a/src/Database/Bloodhound/Raw.hs b/src/Database/Bloodhound/Raw.hs index ccce3c997..e8ce1520b 100644 --- a/src/Database/Bloodhound/Raw.hs +++ b/src/Database/Bloodhound/Raw.hs @@ -15,7 +15,7 @@ module Database.Bloodhound.Raw ( mkTermsCompositeAgg, ) where -import Control.Monad.Catch (MonadThrow) +import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson import Data.Aeson qualified as Aeson import Data.Aeson.Casing.Internal qualified as AesonCasing @@ -62,11 +62,11 @@ advance :: (MonadBH m, MonadThrow m, FromJSON resp) => BH.ScrollId -> m (BH.Sear advance scroll = do resp <- BH.advanceScroll scroll 60 case resp of - Left e -> handleError e + Left err -> throwEsError mempty err Right x -> pure x - where - handleError resp = do - error $ "Elastic scroll response failed" <> show resp + +throwEsError :: MonadThrow m => LByteString -> BH.EsError -> m a +throwEsError resp err = throwM $ BH.EsProtocolException err.errorMessage resp settings :: (MonadBH m, ToJSON body) => BH.IndexName -> body -> m () settings (BH.IndexName index) body = do @@ -104,7 +104,7 @@ search index body scrollRequest = do rawResp <- search' index newBody qs resp <- BH.parseEsResponse rawResp case resp of - Left e -> handleError e rawResp + Left err -> throwEsError mempty err Right x -> pure x where newBody = case (fields, toJSON body) of @@ -125,9 +125,6 @@ search index body scrollRequest = do qs = case scrollRequest of NoScroll -> [] GetScroll x -> [("scroll", Just x)] - handleError _resp rawResp = do - -- logWarn "Elastic response failed" ["status" .= BH.errorStatus resp, "message" .= BH.errorMessage resp] - error $ "Elastic response failed: " <> show rawResp -- | A special purpose search implementation that uses the faster json-syntax searchHit :: diff --git a/src/Macroscope/Test.hs b/src/Macroscope/Test.hs index 835c7dd93..a599e5bbf 100644 --- a/src/Macroscope/Test.hs +++ b/src/Macroscope/Test.hs @@ -37,7 +37,7 @@ runLentilleM client action = do testCrawlingPoint :: Assertion testCrawlingPoint = do appEnv <- mkAppEnv fakeConfig - runAppEnv appEnv $ runEmptyQueryM fakeConfig do + runAppEnv appEnv $ runEmptyQueryM fakeConfig $ dieOnEsError do I.ensureIndexSetup let fakeChange1 = BT.fakeChange @@ -124,7 +124,7 @@ testTaskDataMacroscope = withTestApi appEnv $ \client -> testAction client | otherwise = error $ "Unexpected product entity: " <> show project void $ runLentilleM client $ Macroscope.runStream apiKey indexName (CrawlerName crawlerName) (Macroscope.TaskDatas stream) -- Check task data got indexed - withTenantConfig fakeConfig do + withTenantConfig fakeConfig $ dieOnEsError do count <- withQuery taskDataQuery $ Streaming.length_ Q.scanSearchId liftIO (assertEqual "Task data got indexed by macroscope" count 1) diff --git a/src/Monocle/Api/Server.hs b/src/Monocle/Api/Server.hs index 0e5169eb7..2d166402d 100644 --- a/src/Monocle/Api/Server.hs +++ b/src/Monocle/Api/Server.hs @@ -94,7 +94,7 @@ updateIndex index wsRef = E.modifyMVar_ wsRef doUpdateIfNeeded Nothing -> error $ "Unknown workspace: " <> show (Config.getWorkspaceName index) refreshIndex :: Eff es () - refreshIndex = do + refreshIndex = dieOnEsError do logInfo "RefreshIndex" ["index" .= Config.getWorkspaceName index] runRetry I.ensureIndexSetup traverse_ I.initCrawlerMetadata index.crawlers @@ -171,7 +171,7 @@ loginLoginValidation _auth request = do validateOnIndex :: Text -> Config.Index -> MaybeT (Eff es) () validateOnIndex username index = do let userQuery = Q.toUserTerm username - count <- lift $ runEmptyQueryM index $ withFilter [userQuery] Q.countDocs + count <- lift $ dieOnEsError $ runEmptyQueryM index $ withFilter [userQuery] Q.countDocs when (count > 0) mzero -- | /api/2/about endpoint @@ -314,7 +314,7 @@ crawlerAddDoc _auth request = do pure (index, crawler) case requestE of - Right (index, crawler) -> runEmptyQueryM index do + Right (index, crawler) -> runEmptyQueryM index $ dieOnEsError do unless (V.null errors) do addErrors crawlerName (toEntity entity) errors case toEntity entity of @@ -405,7 +405,7 @@ crawlerCommit _auth request = do pure (index, ts, toEntity entityPB) case requestE of - Right (index, ts, entity) -> runEmptyQueryM index $ do + Right (index, ts, entity) -> runEmptyQueryM index $ dieOnEsError $ do let date = Timestamp.toUTCTime ts logInfo "UpdatingEntity" ["crawler" .= crawlerName, "entity" .= entity, "date" .= date] -- TODO: check for CommitDateInferiorThanPrevious @@ -445,7 +445,7 @@ crawlerCommitInfo _auth request = do case requestE of Right (index, worker, entityType) -> do - runEmptyQueryM index $ do + runEmptyQueryM index $ dieOnEsError do updateIndex index wsStatus toUpdateEntityM <- I.getLastUpdated worker (fromPBEnum entityType) offset case toUpdateEntityM of @@ -487,7 +487,7 @@ searchSuggestions auth request = checkAuth auth . const $ do case tenantM of Just tenant -> do now <- getCurrentTime - runQueryM tenant (emptyQ now) $ Q.getSuggestions tenant + runQueryM tenant (emptyQ now) $ dieOnEsError $ Q.getSuggestions tenant Nothing -> -- Simply return empty suggestions in case of unknown tenant pure @@ -531,7 +531,7 @@ searchAuthor auth request = checkAuth auth . const $ do authorAliases = V.fromList $ from <$> aliases authorGroups = V.fromList $ from <$> fromMaybe mempty groups in SearchPB.Author {..} - found <- runEmptyQueryM index $ I.searchAuthorCache . from $ authorRequestQuery + found <- runEmptyQueryM index $ dieOnEsError $ I.searchAuthorCache . from $ authorRequestQuery pure $ toSearchAuthor <$> found Nothing -> pure [] @@ -570,7 +570,7 @@ crawlerErrors auth request = checkAuth auth response requestE <- validateSearchRequest request.errorsRequestIndex request.errorsRequestQuery "nobody" case requestE of - Right (tenant, query) -> runQueryM tenant (Q.ensureMinBound query) $ do + Right (tenant, query) -> runQueryM tenant (Q.ensureMinBound query) $ dieOnEsError do logInfo "ListingErrors" ["index" .= request.errorsRequestIndex] errors <- toErrorsList <$> Q.crawlerErrors pure $ CrawlerPB.ErrorsResponse $ Just $ CrawlerPB.ErrorsResponseResultSuccess $ CrawlerPB.ErrorsList $ fromList errors @@ -611,7 +611,7 @@ searchQuery auth request = checkAuth auth response requestE <- validateSearchRequest queryRequestIndex queryRequestQuery username case requestE of - Right (tenant, query) -> runQueryM tenant (Q.ensureMinBound query) $ do + Right (tenant, query) -> runQueryM tenant (Q.ensureMinBound query) $ dieOnEsError do let queryType = fromPBEnum queryRequestQueryType logInfo "Searching" @@ -946,9 +946,10 @@ metricGet auth request = checkAuth auth response -- Unknown query _ -> handleError $ "Unknown metric: " <> from getRequestMetric where - runM :: Eff (MonoQuery : es) a -> Eff es a - runM = runQueryM tenant (Q.ensureMinBound query) - runMetric :: (TrendPB a, TopPB a, NumPB a) => Q.Metric (MonoQuery : es) a -> Eff es MetricPB.GetResponse + runM :: Eff (MonoQuery : Error ElasticError : es) a -> Eff es a + runM = dieOnEsError . runQueryM tenant (Q.ensureMinBound query) + + runMetric :: (TrendPB a, TopPB a, NumPB a) => Q.Metric (MonoQuery : Error ElasticError : es) a -> Eff es MetricPB.GetResponse runMetric m = case getRequestOptions of Just (MetricPB.GetRequestOptionsTrend (MetricPB.Trend interval)) -> toTrendResult <$> runM (Q.runMetricTrend m $ fromPBTrendInterval $ from interval) diff --git a/src/Monocle/Api/ServerHTMX.hs b/src/Monocle/Api/ServerHTMX.hs index 9a8b5f305..b9f995c98 100644 --- a/src/Monocle/Api/ServerHTMX.hs +++ b/src/Monocle/Api/ServerHTMX.hs @@ -10,7 +10,7 @@ import Monocle.Api.Server (searchAuthor) import Monocle.Backend.Documents (EDocType (ECachedAuthor)) import Monocle.Backend.Queries (documentType) import Monocle.Config qualified as Config -import Monocle.Effects (ApiEffects, esCountByIndex) +import Monocle.Effects (ApiEffects, dieOnEsError, esCountByIndex) import Monocle.Env (tenantIndexName) import Monocle.Prelude import Monocle.Protob.Search (AuthorRequest (..)) @@ -59,7 +59,8 @@ searchAuthorsHandler auth (Just index) queryM = do indexVal :: Text indexVal = from index countCachedAuthors = do - resp <- esCountByIndex (tenantIndexName index) $ BH.CountQuery $ documentType ECachedAuthor + resp <- dieOnEsError do + esCountByIndex (tenantIndexName index) $ BH.CountQuery $ documentType ECachedAuthor case resp of Right (BH.CountResponse nat _) -> pure nat Left _ -> pure 0 diff --git a/src/Monocle/Api/Test.hs b/src/Monocle/Api/Test.hs index f9056e9e2..6357bcb56 100644 --- a/src/Monocle/Api/Test.hs +++ b/src/Monocle/Api/Test.hs @@ -18,7 +18,7 @@ import Servant.Auth.Server ( generateKey, ) -import Database.Bloodhound qualified as BH +import Database.Bloodhound qualified as BH (BHEnv) import Effectful.Error.Static qualified as E import Effectful.Fail qualified as E import Effectful.Reader.Static qualified as E @@ -69,7 +69,7 @@ withTestApi appEnv' testCb = bracket appEnv' cleanIndex runTest jwtCfg = appEnv.aOIDC.localJWTSettings cfg = jwtCfg :. cookieCfg :. EmptyContext traverse_ - (\index -> runEmptyQueryM index I.ensureIndex) + (\index -> dieOnEsError $ runEmptyQueryM index I.ensureIndex) indexes unsafeEff $ \es -> let app = Effectful.Servant.hoistEff @RootAPI es cfg (rootServer cookieCfg) diff --git a/src/Monocle/Backend/Index.hs b/src/Monocle/Backend/Index.hs index 56adefd44..fbbdc15b9 100644 --- a/src/Monocle/Backend/Index.hs +++ b/src/Monocle/Backend/Index.hs @@ -465,14 +465,14 @@ ensureConfigIndex = do traverseWorkspace action conf = do traverse_ (\ws -> localQueryTarget (QueryWorkspace ws) action) (Config.getWorkspaces conf) -ensureIndexSetup :: (MonoQuery :> es, LoggerEffect :> es, ElasticEffect :> es, Retry :> es) => Eff es () +ensureIndexSetup :: (MonoQuery :> es, LoggerEffect :> es, Error ElasticError :> es, ElasticEffect :> es, Retry :> es) => Eff es () ensureIndexSetup = do indexName <- getIndexName logInfo "Ensure workspace " ["index" .= indexName] createIndex indexName ChangesIndexMapping esSettings indexName (object ["index" .= object ["max_regex_length" .= (50_000 :: Int)]]) -ensureIndexCrawlerMetadata :: (E.Fail :> es, LoggerEffect :> es, ElasticEffect :> es, MonoQuery :> es) => Eff es () +ensureIndexCrawlerMetadata :: (E.Fail :> es, LoggerEffect :> es, Error ElasticError :> es, ElasticEffect :> es, MonoQuery :> es) => Eff es () ensureIndexCrawlerMetadata = do QueryWorkspace config <- getQueryTarget traverse_ initCrawlerMetadata config.crawlers @@ -485,13 +485,13 @@ withRefresh action = do refreshResp <- esRefreshIndex index unless (BH.isSuccess refreshResp) (error $ "Unable to refresh index: " <> show resp) -ensureIndex :: (E.Fail :> es, LoggerEffect :> es, MonoQuery :> es, ElasticEffect :> es, Retry :> es) => Eff es () +ensureIndex :: (E.Fail :> es, LoggerEffect :> es, MonoQuery :> es, Error ElasticError :> es, ElasticEffect :> es, Retry :> es) => Eff es () ensureIndex = do ensureIndexSetup ensureIndexCrawlerMetadata removeIndex :: (E.Fail :> es, MonoQuery :> es, ElasticEffect :> es) => Eff es () -removeIndex = do +removeIndex = dieOnEsError do indexName <- getIndexName _resp <- esDeleteIndex indexName False <- esIndexExists indexName @@ -746,7 +746,7 @@ data TaskDataDoc = TaskDataDoc type TaskDataOrphanDoc = TaskDataDoc -getOrphanTaskDataByChangeURL :: forall es. (ElasticEffect :> es, MonoQuery :> es) => [Text] -> Eff es [EChangeOrphanTD] +getOrphanTaskDataByChangeURL :: forall es. (Error ElasticError :> es, ElasticEffect :> es, MonoQuery :> es) => [Text] -> Eff es [EChangeOrphanTD] getOrphanTaskDataByChangeURL urls = do index <- getIndexName results <- scanSearch index diff --git a/src/Monocle/Backend/Provisioner.hs b/src/Monocle/Backend/Provisioner.hs index bfc0c71e7..c985d39db 100644 --- a/src/Monocle/Backend/Provisioner.hs +++ b/src/Monocle/Backend/Provisioner.hs @@ -31,7 +31,7 @@ import Google.Protobuf.Timestamp qualified (fromUTCTime) import Monocle.Backend.Documents import Monocle.Backend.Test qualified as T import Monocle.Config (csConfig, getWorkspaces, lookupTenant, mkIndexName) -import Monocle.Effects (getReloadConfig, runElasticEffect, runEmptyQueryM, runMonoConfig) +import Monocle.Effects (dieOnEsError, getReloadConfig, runElasticEffect, runEmptyQueryM, runMonoConfig) import Monocle.Env (mkEnv) import Monocle.Prelude import Monocle.Protob.Search (TaskData (..)) @@ -50,7 +50,7 @@ runProvisioner configPath elasticUrl tenantName docCount = do case tenantM of Just tenant -> do bhEnv <- mkEnv elasticUrl - r <- runRetry $ runFail $ runElasticEffect bhEnv $ do + r <- runRetry $ runFail $ runElasticEffect bhEnv $ dieOnEsError do events <- liftIO $ createFakeEvents docCount runEmptyQueryM tenant $ T.indexScenario events logInfo "Provisionned" ["index" .= indexName, "doc count" .= length events] diff --git a/src/Monocle/Backend/Queries.hs b/src/Monocle/Backend/Queries.hs index 8d9038f4f..7497f5254 100644 --- a/src/Monocle/Backend/Queries.hs +++ b/src/Monocle/Backend/Queries.hs @@ -30,7 +30,7 @@ import Monocle.Effects import Proto3.Suite (Enumerated (Enumerated)) -- Legacy wrappers -simpleSearchLegacy :: (LoggerEffect :> es, ElasticEffect :> es, FromJSON a) => BH.IndexName -> BH.Search -> Eff es [BH.Hit a] +simpleSearchLegacy :: (LoggerEffect :> es, Error ElasticError :> es, ElasticEffect :> es, FromJSON a) => BH.IndexName -> BH.Search -> Eff es [BH.Hit a] simpleSearchLegacy indexName search = BH.hits . BH.searchHits <$> esSearchLegacy indexName search ------------------------------------------------------------------------------- @@ -1778,7 +1778,7 @@ allMetrics :: [MetricInfo] allMetrics = map metricInfo - [ toJSON <$> metricChangesCreated @[ElasticEffect, LoggerEffect, MonoQuery] + [ toJSON <$> metricChangesCreated @[ElasticEffect, Error ElasticError, LoggerEffect, MonoQuery] , toJSON <$> metricChangesMerged , toJSON <$> metricChangesAbandoned , toJSON <$> metricChangesSelfMerged diff --git a/src/Monocle/Backend/Test.hs b/src/Monocle/Backend/Test.hs index 383cb33cb..1b8598684 100644 --- a/src/Monocle/Backend/Test.hs +++ b/src/Monocle/Backend/Test.hs @@ -148,7 +148,7 @@ withTenantConfig ws action = do withEffToIO $ \runInIO -> bracket_ (runInIO create) (runInIO delete) (runInIO action) where - create = runRetry $ E.runFailIO I.ensureIndex + create = runRetry $ E.runFailIO $ dieOnEsError I.ensureIndex delete = E.runFailIO I.removeIndex checkEChangeField :: TestEffects es => (Show a, Eq a) => BH.DocId -> (EChange -> a) -> a -> Eff es () @@ -180,7 +180,7 @@ testIndexChanges :: Assertion testIndexChanges = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = E.runFailIO do + doTest = E.runFailIO $ dieOnEsError do -- Index two Changes and check present in database I.indexChanges [fakeChange1, fakeChange2] checkDocExists' $ I.getChangeDocId fakeChange1 @@ -242,7 +242,7 @@ testIndexChanges = withTenant doTest testIndexEvents :: Assertion testIndexEvents = do - withTenant $ E.runFailIO do + withTenant $ E.runFailIO $ dieOnEsError do let evt1 = emptyEvent {echangeeventType = EChangeCommentedEvent, echangeeventId = "1"} evt2 = emptyEvent {echangeeventType = EChangeMergedEvent, echangeeventId = "2", echangeeventDraft = Just True} I.indexEvents [evt1, evt2] @@ -256,7 +256,7 @@ testProjectCrawlerMetadata :: Assertion testProjectCrawlerMetadata = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do -- Init default crawler metadata and ensure we get the default updated date I.initCrawlerMetadata workerGitlab lastUpdated <- I.getLastUpdated workerGitlab entityType 0 @@ -334,7 +334,7 @@ testOrganizationCrawlerMetadata :: Assertion testOrganizationCrawlerMetadata = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do -- Init crawler entities metadata and check we get the default date I.initCrawlerMetadata worker lastUpdated <- I.getLastUpdated worker entityType 0 @@ -374,7 +374,7 @@ testTaskDataCrawlerMetadata :: Assertion testTaskDataCrawlerMetadata = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do -- Init default crawler metadata and ensure we get the default updated date I.initCrawlerMetadata workerGithub lastUpdated <- I.getLastUpdated workerGithub entityType 0 @@ -409,7 +409,7 @@ testTaskDataCrawlerMetadata = withTenant doTest fakeDateB = [utctime|2021-05-31 10:00:00|] testEnsureConfig :: Assertion -testEnsureConfig = withTenantConfig tenantConfig $ localQueryTarget target $ runRetry $ E.runFailIO do +testEnsureConfig = withTenantConfig tenantConfig $ localQueryTarget target $ runRetry $ E.runFailIO $ dieOnEsError do I.ensureIndexSetup I.ensureConfigIndex (currentVersion, _) <- I.getConfigVersion @@ -421,7 +421,7 @@ testEnsureConfig = withTenantConfig tenantConfig $ localQueryTarget target $ run testUpgradeConfigV3 :: Assertion testUpgradeConfigV3 = do -- Index some events, run upgradeConfigV3, and check self_merged added on EChangeMergedEvent - withTenant $ E.runFailIO do + withTenant $ E.runFailIO $ dieOnEsError do let evt1 = emptyEvent {echangeeventType = EChangeCommentedEvent, echangeeventId = "1"} -- emptyEvent set the same author for author and onAuthor attribute evt2 = emptyEvent {echangeeventType = EChangeMergedEvent, echangeeventId = "2"} @@ -444,7 +444,7 @@ testUpgradeConfigV3 = do testUpgradeConfigV4 :: Assertion testUpgradeConfigV4 = do -- Index a change with negative duration, run upgradeConfigV4, and check for absolute value - withTenant $ E.runFailIO do + withTenant $ E.runFailIO $ dieOnEsError do let change1 = emptyChange { echangeId = "change1" @@ -466,7 +466,7 @@ testUpgradeConfigV4 = do testUpgradeConfigV1 :: Assertion testUpgradeConfigV1 = do -- Index docs, run upgradeConfigV1, and check project crawler MD state - withTenantConfig tenantConfig $ E.runFailIO $ do + withTenantConfig tenantConfig $ E.runFailIO $ dieOnEsError do -- Index some events and set lastCommitAt for the first (repoGH1 and repoGL1) project crawler MD setDocs crawlerGH crawlerGHName "org/repoGH1" "org/repoGH2" setDocs crawlerGL crawlerGLName "org/repoGL1" "org/repoGL2" @@ -496,7 +496,7 @@ testUpgradeConfigV1 = do let entity = Project repoName in entityDocID (CrawlerName crawlerName) entity setDocs :: (MonoQuery :> es, ElasticEffect :> es, LoggerEffect :> es) => Config.Crawler -> Text -> Text -> Text -> (Eff es) () - setDocs crawler crawlerName repo1 repo2 = do + setDocs crawler crawlerName repo1 repo2 = dieOnEsError do -- Init crawler metadata I.initCrawlerMetadata crawler -- Index two events @@ -568,7 +568,7 @@ testJanitorWipeCrawler = withTenant $ localQueryTarget updateEnv doTest , search_aliases = Nothing } doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do I.initCrawlerMetadata workerGerrit I.indexChanges [ emptyChange @@ -612,7 +612,7 @@ testJanitorUpdateIdents = do expectedAuthor = Author "John Doe" "github.com/john" ["dev", "core"] doUpdateIndentOnEventsTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doUpdateIndentOnEventsTest = E.runFailIO do + doUpdateIndentOnEventsTest = E.runFailIO $ dieOnEsError do I.indexEvents [evt1, evt2] count <- J.updateIdentsOnEvents assertEqual' "Ensure updated events count" 1 count @@ -635,7 +635,7 @@ testJanitorUpdateIdents = do mkEvent 0 fakeDate EChangeCommentedEvent eAuthor eAuthor (from eid) mempty doUpdateIndentOnChangesTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doUpdateIndentOnChangesTest = E.runFailIO do + doUpdateIndentOnChangesTest = E.runFailIO $ dieOnEsError do I.indexChanges [change1, change2, change3] count <- J.updateIdentsOnChanges -- change1 and change3 will be updated @@ -693,7 +693,7 @@ testAchievements :: Assertion testAchievements = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do indexScenario (nominalMerge (scenarioProject "openstack/nova") "42" fakeDate 3600) -- Try query @@ -735,7 +735,7 @@ testGetInfoMetric = withTenantConfig tenant do _ -> Nothing testGetMetrics :: Assertion -testGetMetrics = withTenantConfig tenant do +testGetMetrics = withTenantConfig tenant $ dieOnEsError do -- Add data to the index indexScenario (nominalMerge (scenarioProject "openstack/nova") "42" fakeDate 1800) @@ -772,7 +772,7 @@ testReposSummary :: Assertion testReposSummary = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do indexScenario (nominalMerge (scenarioProject "openstack/nova") "42" fakeDate 3600) indexScenario (nominalMerge (scenarioProject "openstack/neutron") "43" fakeDate 3600) indexScenario (nominalMerge (scenarioProject "openstack/neutron") "44" fakeDate 3600) @@ -812,7 +812,7 @@ testTopAuthors :: Assertion testTopAuthors = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do -- Prapare data let nova = SProject "openstack/nova" [alice] [alice] [eve] let neutron = SProject "openstack/neutron" [bob] [alice] [eve] @@ -866,7 +866,7 @@ testGetAuthorsPeersStrength :: Assertion testGetAuthorsPeersStrength = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do -- Prapare data let nova = SProject "openstack/nova" [bob] [alice] [eve] let neutron = SProject "openstack/neutron" [alice] [eve] [bob] @@ -916,7 +916,7 @@ testGetNewContributors = withTenant doTest where indexScenario' project fakeDate' cid = indexScenario (nominalMerge project cid fakeDate' 3600) doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do -- Prapare data let sn1 = SProject "openstack/nova" [bob] [alice] [eve] let sn2 = SProject "openstack/nova" [bob] [alice] [bob] @@ -945,7 +945,7 @@ testLifecycleStats :: Assertion testLifecycleStats = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do traverse_ (indexScenarioNM (SProject "openstack/nova" [alice] [bob] [eve])) ["42", "43"] let query = let queryGet _ = const [] @@ -964,7 +964,7 @@ testGetActivityStats :: Assertion testGetActivityStats = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do -- Prapare data let nova = SProject "openstack/nova" [alice] [alice] [eve] let neutron = SProject "openstack/neutron" [bob] [alice] [eve] @@ -1013,7 +1013,7 @@ testGetChangesTops :: Assertion testGetChangesTops = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do let nova = SProject "openstack/nova" [alice] [alice] [eve] let neutron = SProject "openstack/neutron" [bob] [alice] [eve] traverse_ (indexScenarioNM nova) ["42", "43"] @@ -1075,7 +1075,7 @@ testGetSuggestions :: Assertion testGetSuggestions = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do target <- getQueryTarget let nova = SProject "openstack/nova" [alice] [alice] [eve] let neutron = SProject "openstack/neutron" [eve] [alice] [bob] @@ -1105,7 +1105,7 @@ testGetAllAuthorsMuid :: Assertion testGetAllAuthorsMuid = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do traverse_ (indexScenarioNM $ SProject "openstack/nova" [alice] [alice] [eve]) ["42", "43"] withQuery defaultQuery do results <- Q.getAllAuthorsMuid' @@ -1114,7 +1114,7 @@ testGetAllAuthorsMuid = withTenant doTest testAuthorCache :: Assertion testAuthorCache = withTenant doTest where - doTest = do + doTest = dieOnEsError do -- Index a change and some events traverse_ (indexScenarioNM $ SProject "openstack/nova" [alice] [alice] [eve]) ["42", "43"] @@ -1176,7 +1176,7 @@ testTaskDataAdd :: Assertion testTaskDataAdd = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = do + doTest = dieOnEsError do let nova = SProject "openstack/nova" [alice] [alice] [eve] traverse_ (indexScenarioNM nova) ["42", "43", "44"] @@ -1251,14 +1251,14 @@ testTaskDataAdd = withTenant doTest ) orphanTdM' - getOrphanTd :: Text -> Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] (Maybe EChangeOrphanTD) - getOrphanTd url = I.getDocumentById $ I.getBHDocID url + getOrphanTd :: Text -> Eff [Error ElasticError, MonoQuery, ElasticEffect, LoggerEffect, IOE] (Maybe EChangeOrphanTD) + getOrphanTd url = dieOnEsError $ I.getDocumentById $ I.getBHDocID url testTaskDataAdoption :: Assertion testTaskDataAdoption = withTenant doTest where doTest :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () - doTest = + doTest = dieOnEsError do -- Send Task data w/o a matching change (orphan task data) let td42 = mkTaskData "42" diff --git a/src/Monocle/Effects.hs b/src/Monocle/Effects.hs index 43fb30667..004fed105 100644 --- a/src/Monocle/Effects.hs +++ b/src/Monocle/Effects.hs @@ -59,6 +59,9 @@ module Monocle.Effects where import Monocle.Prelude hiding (Reader, ask, local) import Control.Exception (finally) +import Control.Exception.Base (ErrorCall (ErrorCall)) +import Control.Monad.Catch (catches) +import Data.Text qualified as T import Monocle.Client qualified import Monocle.Config qualified import Network.HTTP.Client (HttpException (..)) @@ -114,10 +117,10 @@ type ApiEffects es = ) -- the effect necessary to run elastic request -type IndexEffects es = (ElasticEffect :> es, LoggerEffect :> es) +type IndexEffects es = (Error ElasticError :> es, ElasticEffect :> es, LoggerEffect :> es) -- the query handler :> es, previously known as QueryM -type QEffects es = (ElasticEffect :> es, LoggerEffect :> es, MonoQuery :> es) +type QEffects es = (ElasticEffect :> es, Error ElasticError :> es, LoggerEffect :> es, MonoQuery :> es) -- the macro handler :> es, previously known as LentilleM type CrawlerEffects es = (LoggerEffect :> es, MonoClientEffect :> es) @@ -366,98 +369,143 @@ runElasticEffect bhEnv action = do -- bhEnv <- liftIO (BH.mkBHEnv <$> pure server <*> Monocle.Client.mkManager) evalStaticRep (ElasticEffect bhEnv) action -esSearch :: (ElasticEffect :> es, ToJSON body, FromJSONField resp) => BH.IndexName -> body -> BHR.ScrollRequest -> Eff es (BH.SearchResult resp) -esSearch iname body scrollReq = do +-- | ElasticError are produced by the es client +data ElasticError = ElasticError + { call :: Text + -- ^ A describe name of the action, e.g. 'search' + , msg :: Text + -- ^ The error message + , req :: Text + -- ^ The request body JSON encoded + , resp :: LByteString + -- ^ The api responde body + } + deriving (Show) + +-- | This function runs a BH IO safely by catching EsProtocolExceptions (which contains json decoding errors). +-- After using this function, a new Error effect is added to the 'es' constraint. +-- Use 'runEsError' to discharge the new effect and access the final result 'a'. +runBHIOSafe :: + HasCallStack => + (ToJSON body, Error ElasticError :> es, ElasticEffect :> es) => + -- | The action name to be recorded in the error + Text -> + -- | A copy of the body to be recorded in the error + body -> + -- | The bloodhound action + BH.BH IO a -> + Eff es a +runBHIOSafe call bodyJSON act = do ElasticEffect env <- getStaticRep - -- unsafeEff_ $ BH.runBH env $ BHR.search iname (trace (show $ encode body) body) scrollReq - unsafeEff_ $ BH.runBH env $ BHR.search iname body scrollReq + eRes <- unsafeEff_ ((Right <$> BH.runBH env act) `catches` [errorHandler, esHandler]) + case eRes of + Right x -> pure x + Left e -> throwError e + where + toErr msg err = pure $ Left $ ElasticError call msg body err + errorHandler = Handler $ \(ErrorCall err) -> toErr (from err) "error called" + esHandler = Handler $ \(BH.EsProtocolException msg resp) -> toErr msg resp + body = decodeUtf8 $ encode bodyJSON + +-- | Safely remove (Error ElasticError) from the list of effect. +runEsError :: Eff (Error ElasticError : es) a -> Eff es (Either (CallStack, ElasticError) a) +runEsError = E.runError + +-- | Hard remove (Error ElasticError) from the list of effect by using 'error' +-- This used to be the default behavior. +dieOnEsError :: Eff (Error ElasticError : es) a -> Eff es a +dieOnEsError act = + runEsError act >>= \case + Left (tb, err) -> + error + $ mconcat + [ err.call + , ": " + , err.msg + , ", req: " + , T.take 120 err.req + , ", resp: " + , -- cut the message to avoid filling the term. this needs to be indexed for proper debug + T.take 120 (decodeUtf8 err.resp) + , ", tb: " + , show tb + ] + Right x -> pure x + +esSearch :: (Error ElasticError :> es, ElasticEffect :> es, ToJSON body, FromJSONField resp) => BH.IndexName -> body -> BHR.ScrollRequest -> Eff es (BH.SearchResult resp) +esSearch iname body scrollReq = do + runBHIOSafe "esSearch" body $ BHR.search iname body scrollReq -esAdvance :: (ElasticEffect :> es, FromJSON resp) => BH.ScrollId -> Eff es (BH.SearchResult resp) +esAdvance :: (Error ElasticError :> es, ElasticEffect :> es, FromJSON resp) => BH.ScrollId -> Eff es (BH.SearchResult resp) esAdvance scroll = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BHR.advance scroll + runBHIOSafe "esAdvance" scroll $ BHR.advance scroll -esGetDocument :: ElasticEffect :> es => BH.IndexName -> BH.DocId -> Eff es (HTTP.Response LByteString) +esGetDocument :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> BH.DocId -> Eff es (HTTP.Response LByteString) esGetDocument iname doc = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.getDocument iname doc + runBHIOSafe "esGetDocument" doc $ BH.getDocument iname doc -esCountByIndex :: ElasticEffect :> es => BH.IndexName -> BH.CountQuery -> Eff es (Either BH.EsError BH.CountResponse) +esCountByIndex :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> BH.CountQuery -> Eff es (Either BH.EsError BH.CountResponse) esCountByIndex iname q = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.countByIndex iname q + runBHIOSafe "esCountByIndex" q $ BH.countByIndex iname q -esSearchHit :: ElasticEffect :> es => ToJSON body => BH.IndexName -> body -> Eff es [Json.Value] +esSearchHit :: (Error ElasticError :> es, ElasticEffect :> es) => ToJSON body => BH.IndexName -> body -> Eff es [Json.Value] esSearchHit iname body = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BHR.searchHit iname body + runBHIOSafe "esSearchHit" body $ BHR.searchHit iname body -esScanSearch :: ElasticEffect :> es => FromJSON body => BH.IndexName -> BH.Search -> Eff es [BH.Hit body] +esScanSearch :: (Error ElasticError :> es, ElasticEffect :> es) => FromJSON body => BH.IndexName -> BH.Search -> Eff es [BH.Hit body] esScanSearch iname search = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.scanSearch iname search + runBHIOSafe "esScanSearch" search $ BH.scanSearch iname search -esDeleteByQuery :: ElasticEffect :> es => BH.IndexName -> BH.Query -> Eff es BH.Reply +esDeleteByQuery :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> BH.Query -> Eff es BH.Reply esDeleteByQuery iname q = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.deleteByQuery iname q + runBHIOSafe "esDeleteByQuery" q $ BH.deleteByQuery iname q -esCreateIndex :: ElasticEffect :> es => BH.IndexSettings -> BH.IndexName -> Eff es () +esCreateIndex :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexSettings -> BH.IndexName -> Eff es () esCreateIndex is iname = do - ElasticEffect env <- getStaticRep -- TODO: check for error - unsafeEff_ $ void $ BH.runBH env $ BH.createIndex is iname + void $ runBHIOSafe "esCreateIndex" iname $ BH.createIndex is iname -esIndexDocument :: ToJSON body => ElasticEffect :> es => BH.IndexName -> BH.IndexDocumentSettings -> body -> BH.DocId -> Eff es (HTTP.Response LByteString) +esIndexDocument :: (ToJSON body, Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> BH.IndexDocumentSettings -> body -> BH.DocId -> Eff es (HTTP.Response LByteString) esIndexDocument indexName docSettings body docId = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.indexDocument indexName docSettings body docId + runBHIOSafe "esIndexDocument" body $ BH.indexDocument indexName docSettings body docId -esPutMapping :: ElasticEffect :> es => ToJSON mapping => BH.IndexName -> mapping -> Eff es () +esPutMapping :: (Error ElasticError :> es, ElasticEffect :> es) => ToJSON mapping => BH.IndexName -> mapping -> Eff es () esPutMapping iname mapping = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ void $ BH.runBH env $ BH.putMapping iname mapping + -- TODO: check for error + void $ runBHIOSafe "esPutMapping" mapping $ BH.putMapping iname mapping -esIndexExists :: ElasticEffect :> es => BH.IndexName -> Eff es Bool +esIndexExists :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> Eff es Bool esIndexExists iname = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.indexExists iname + runBHIOSafe "esIndexExists" iname $ BH.indexExists iname -esDeleteIndex :: ElasticEffect :> es => BH.IndexName -> Eff es (HTTP.Response LByteString) +esDeleteIndex :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> Eff es (HTTP.Response LByteString) esDeleteIndex iname = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.deleteIndex iname + runBHIOSafe "esDeleteIndex" iname $ BH.deleteIndex iname -esSettings :: ElasticEffect :> es => ToJSON body => BH.IndexName -> body -> Eff es () +esSettings :: (Error ElasticError :> es, ElasticEffect :> es) => ToJSON body => BH.IndexName -> body -> Eff es () esSettings iname body = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BHR.settings iname body + runBHIOSafe "esSettings" body $ BHR.settings iname body -esRefreshIndex :: ElasticEffect :> es => BH.IndexName -> Eff es (HTTP.Response LByteString) +esRefreshIndex :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> Eff es (HTTP.Response LByteString) esRefreshIndex iname = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.refreshIndex iname + runBHIOSafe "esRefreshIndex" iname $ BH.refreshIndex iname -esDocumentExists :: ElasticEffect :> es => BH.IndexName -> BH.DocId -> Eff es Bool +esDocumentExists :: (Error ElasticError :> es, ElasticEffect :> es) => BH.IndexName -> BH.DocId -> Eff es Bool esDocumentExists iname doc = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.documentExists iname doc + runBHIOSafe "esDocumentExists" doc $ BH.documentExists iname doc -esBulk :: ElasticEffect :> es => V.Vector BulkOperation -> Eff es BH.Reply +esBulk :: (Error ElasticError :> es, ElasticEffect :> es) => V.Vector BulkOperation -> Eff es BH.Reply esBulk ops = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.bulk ops + runBHIOSafe "esBulk" ([] :: [Bool]) $ BH.bulk ops -esUpdateDocument :: ElasticEffect :> es => ToJSON a => BH.IndexName -> BH.IndexDocumentSettings -> a -> DocId -> Eff es BH.Reply +esUpdateDocument :: (Error ElasticError :> es, ElasticEffect :> es) => ToJSON a => BH.IndexName -> BH.IndexDocumentSettings -> a -> DocId -> Eff es BH.Reply esUpdateDocument iname ids body doc = do - ElasticEffect env <- getStaticRep - unsafeEff_ $ BH.runBH env $ BH.updateDocument iname ids body doc + runBHIOSafe "esUpdateDocument" body $ BH.updateDocument iname ids body doc -- Legacy wrappers -esSearchLegacy :: (LoggerEffect :> es, ElasticEffect :> es, FromJSON a) => BH.IndexName -> BH.Search -> Eff es (BH.SearchResult a) +esSearchLegacy :: (LoggerEffect :> es, Error ElasticError :> es, ElasticEffect :> es, FromJSON a) => BH.IndexName -> BH.Search -> Eff es (BH.SearchResult a) esSearchLegacy indexName search = do - ElasticEffect env <- getStaticRep - (rawResp, resp) <- unsafeEff_ $ BH.runBH env do + (rawResp, resp) <- runBHIOSafe "esSearchLegacy" search do -- logText . decodeUtf8 . encode $ search rawResp <- BH.searchByIndex indexName search -- logText $ show rawResp diff --git a/src/Monocle/Main.hs b/src/Monocle/Main.hs index 813592d9a..b594ef848 100644 --- a/src/Monocle/Main.hs +++ b/src/Monocle/Main.hs @@ -157,8 +157,9 @@ run' ApiConfig {..} aplogger = E.runConcurrent $ runLoggerEffect do bhEnv <- mkEnv elasticUrl r <- runRetry $ E.runFail $ runElasticEffect bhEnv do - traverse_ (`runEmptyQueryM` I.ensureIndex) workspaces - runMonoQuery (MonoQueryEnv (QueryConfig conf) (mkQuery [])) I.ensureConfigIndex + dieOnEsError do + traverse_ (`runEmptyQueryM` I.ensureIndex) workspaces + runMonoQuery (MonoQueryEnv (QueryConfig conf) (mkQuery [])) I.ensureConfigIndex let settings = Warp.setPort port $ Warp.setLogger httpLogger Warp.defaultSettings jwtCfg = localJWTSettings